# Selima Website Content Management System
# Mail.pm: The mail composer and sender.

#  Copyright (c) 2004-2018 imacat.
#
#  Licensed under the Apache License, Version 2.0 (the "License");
#  you may not use this file except in compliance with the License.
#  You may obtain a copy of the License at
#
#      http://www.apache.org/licenses/LICENSE-2.0
#
#  Unless required by applicable law or agreed to in writing, software
#  distributed under the License is distributed on an "AS IS" BASIS,
#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#  See the License for the specific language governing permissions and
#  limitations under the License.

# Author: imacat <imacat@mail.imacat.idv.tw>
# First written: 2004-10-18

package Selima::Mail;
use 5.008;
use strict;
use warnings;
BEGIN {
# Prototype declaration
sub quote($);
sub rfc822_phrase_need_quoting($);
sub rfc1521_value_need_quoting($);
sub b64hdr_encode($$);
sub rfc822_time(;$);
}

use Digest::MD5 qw(md5_base64);
use Date::Format qw(time2str);
use Encode qw(encode is_utf8 FB_CROAK);
use File::Basename qw(basename);
use File::MMagic qw();
use MIME::Base64 qw(encode_base64);
use MIME::QuotedPrint qw(encode_qp);
use Net::SMTP;
use Time::HiRes qw();
use Socket qw(inet_aton inet_ntoa AF_INET);

BEGIN {
if (exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2) {
    require Apache2::Connection;
}
}

use Selima::Cache qw(:mail);
use Selima::DataVars qw(:env :lninfo :mail);
use Selima::GeoIP;
use Selima::HTTP;
use Selima::HTTPS;
use Selima::LnInfo;
use Selima::LogIn;
use Selima::Server;
use Selima::Unicode;
use Selima::XFileIO;

use vars qw($MM);
$MM = new File::MMagic;

# new: Initialize the e-mail message
sub new : method {
    local ($_, %_);
    my ($class, $self);
    $class = $_[0];
    $self = bless {}, $class;
    
    $self->{"body"} = undef;
    $self->{"parts"} = [];
    $self->{"charset"} = undef;
    $self->{"modified"} = 0;
    $self->{"output"} = undef;
    $self->{"attaches"} = [];
    if (-x "/usr/sbin/sendmail") {
        $self->{"send_with"} = "sendmail";
    } else {
        $self->{"send_with"} = "smtp";
    }
    
    # RFC 821 headers/properties
    $self->{"mail_from"} = undef;
    $self->{"rcpt_to"} = undef;
    # RFC 822 headers/properties
    $self->{"from"} = undef;
    $self->{"subject"} = undef;
    $self->{"sender"} = undef;
    $self->{"to"} = undef;
    $self->{"cc"} = undef;
    $self->{"bcc"} = undef;
    $self->{"reply_to"} = undef;
    # RFC 1521 MIME headers/properties
    $self->{"type"} = "text/plain";
    $self->{"id"} = undef;
    # RFC 1766 Content-Language
    $self->{"lang"} = undef;
    # RFC 1806/2183 Content-Disposition
    $self->{"disposition"} = undef;
    $self->{"filename"} = undef;
    $self->{"filemtime"} = undef;
    $self->{"filesize"} = undef;
    # RFC 1864 Content-MD5
    $self->{"md5"} = 0;
    # RFC 2387 MIME multipart/related headers/properties
    $self->{"related_type"} = undef;
    $self->{"related_start"} = undef;
    # RFC 2369/2919 Mailing Lists headers/properties
    $self->{"list_id"} = undef;
    $self->{"list_help"} = undef;
    $self->{"list_subscribe"} = undef;
    $self->{"list_unsubscribe"} = undef;
    $self->{"list_post"} = undef;
    $self->{"list_owner"} = undef;
    $self->{"list_archive"} = undef;
    # Non-standard headers
    $self->{"errors_to"} = undef;
    $self->{"precedence"} = undef;
    $self->{"mailer"} = "$class http://www.imacat.idv.tw/";
    $self->{"any_header"} = [];
    
    $self->{"boundary_len"} = 32;
    
    return $self;
}

# RFC 821 headers/properties
# mail_from: Set/retrieve the MAIL FROM: sender
sub mail_from : method {
    local ($_, %_);
    my ($self, $email);
    ($self, $email) = @_;
    if (@_ > 1) {
        $self->{"mail_from"} = $email;
        $self->{"modified"} = 1;
    }
    return $self->{"mail_from"};
}
# rcpt_to: Set/retrieve the real recipients (to be used in send())
sub rcpt_to : method {
    local ($_, %_);
    my ($self, $email);
    ($self, $email) = @_;
    # Reset it
    if (!defined $email) {
        undef $self->{"rcpt_to"};
    # Add it
    } else {
        $self->{"rcpt_to"} = []
            if !defined $self->{"rcpt_to"} || ref $self->{"rcpt_to"} ne "ARRAY";
        %_ = map { $_ => 1 } @{$self->{"rcpt_to"}};
        push @{$self->{"rcpt_to"}}, $email
            if !exists $_{$email};
    }
    return undef if !defined $self->{"rcpt_to"};
    return join ",", @{$self->{"rcpt_to"}};
}

# RFC 822 headers/properties
# from: Set/retrieve the From: header
sub from : method {
    local ($_, %_);
    my ($self, $email, $name);
    ($self, $email, $name) = @_;
    $self->_add_addr(\$self->{"from"}, $email, $name)
        if @_ > 1;
    return $self->_ret_addrs($self->{"from"});
}
# subject: Set/retrieve the subject
sub subject : method {
    local ($_, %_);
    my ($self, $subject);
    ($self, $subject) = @_;
    if (@_ > 1) {
        $self->{"subject"} = $subject;
        $self->{"modified"} = 1;
    }
    return $self->{"subject"};
}
# sender: Set/retrieve the Sender: header
sub sender : method {
    local ($_, %_);
    my ($self, $email, $name);
    ($self, $email, $name) = @_;
    $self->_set_addr(\$self->{"sender"}, $email, $name)
        if @_ > 1;
    return $self->_ret_addr($self->{"sender"});
}
# to: Set/retrieve the To: header
sub to : method {
    local ($_, %_);
    my ($self, $email, $name);
    ($self, $email, $name) = @_;
    $self->_add_addr(\$self->{"to"}, $email, $name)
        if @_ > 1;
    return $self->_ret_addrs($self->{"to"});
}
# cc: Set/retrieve the Cc: header
sub cc : method {
    local ($_, %_);
    my ($self, $email, $name);
    ($self, $email, $name) = @_;
    $self->_add_addr(\$self->{"cc"}, $email, $name)
        if @_ > 1;
    return $self->_ret_addrs($self->{"cc"});
}
# bcc: Set/retrieve the Bcc: header
sub bcc : method {
    local ($_, %_);
    my ($self, $email, $name);
    ($self, $email, $name) = @_;
    $self->_add_addr(\$self->{"bcc"}, $email, $name)
        if @_ > 1;
    return $self->_ret_addrs($self->{"bcc"});
}
# reply_to: Set/retrieve the Reply-To: header
sub reply_to : method {
    local ($_, %_);
    my ($self, $email, $name);
    ($self, $email, $name) = @_;
    $self->_add_addr(\$self->{"reply_to"}, $email, $name)
        if @_ > 1;
    return $self->_ret_addrs($self->{"reply_to"});
}

# RFC 1521 MIME headers/properties
# charset: Set/retrieve the desired character set
# Note that this is the desired character set.  The input information
# should still in UTF-8
sub charset : method {
    local ($_, %_);
    my ($self, $charset);
    ($self, $charset) = @_;
    if (@_ > 1) {
        $self->{"charset"} = $charset;
        $self->{"modified"} = 1;
    }
    return $self->{"charset"};
}
# type: Set/retrieve the MIME content type
sub type : method {
    local ($_, %_);
    my ($self, $type);
    ($self, $type) = @_;
    if (@_ > 1) {
        $self->{"type"} = $type;
        $self->{"modified"} = 1;
    }
    return $self->{"type"};
}
# id: Set/retrieve the content ID.
sub id : method {
    local ($_, %_);
    my ($self, $id);
    ($self, $id) = @_;
    if (@_ > 1) {
        # Set a content ID.
        if ($id) {
            if (!defined $self->{"id"}) {
                $self->{"id"} = $self->_new_msgid;
                $self->{"modified"} = 1;
            }
        # Unset the content ID.
        } else {
            if (defined $self->{"id"}) {
                undef $self->{"id"};
                $self->{"modified"} = 1;
            }
        }
    }
    return $self->{"id"};
}

# RFC 1766 Content-Language
# lang: Set/retrieve the language
sub lang : method {
    local ($_, %_);
    my ($self, $lang);
    ($self, $lang) = @_;
    if (@_ > 1) {
        # Reset it
        if (!defined $lang) {
            undef $self->{"lang"};
        # Add it
        } else {
            http_500 "bad language $lang"
                unless is_usascii_printable $lang;
            $lang = encode("US-ASCII", $lang) if is_utf8($lang);
            $self->{"lang"} = []
                if !defined $self->{"lang"} || ref $self->{"lang"} ne "ARRAY";
            push @{$self->{"lang"}}, $lang;
        }
        $self->{"modified"} = 1;
    }
    return undef if !defined $self->{"lang"};
    return join ", ", map ln($_, LN_NAME), @{$self->{"lang"}};
}

# RFC 1806/2183 Content-Disposition
# disposition: Set/retrieve the MIME content disposition
#   "inline" or "attachment"
sub disposition : method {
    local ($_, %_);
    my ($self, $disposition);
    ($self, $disposition) = @_;
    if (@_ > 1) {
        if (!defined $disposition) {
            undef $self->{"disposition"};
        } elsif ($disposition =~ /^(?:inline|attachment)$/) {
            $disposition = encode("US-ASCII", $disposition)
                if is_utf8($disposition);
            $self->{"disposition"} = $disposition;
        } else {
            http_500 "bad content disposition $disposition";
        }
        $self->{"modified"} = 1;
    }
    return $self->{"disposition"};
}
# filename: Set/retrieve the MIME content disposition filename
sub filename : method {
    local ($_, %_);
    my ($self, $filename);
    ($self, $filename) = @_;
    if (@_ > 1) {
        $self->{"filename"} = filename
        $self->{"modified"} = 1;
    }
    return $self->{"filename"};
}
# filemtime: Set/retrieve the MIME content disposition modification time
sub filemtime : method {
    local ($_, %_);
    my ($self, $filemtime);
    ($self, $filemtime) = @_;
    if (@_ > 1) {
        http_500 "bad mtime $filemtime"
            unless $filemtime =~ /^\d+$/;
        $filemtime = encode("US-ASCII", $filemtime) if is_utf8($filemtime);
        $self->{"filemtime"} = $filemtime;
        $self->{"modified"} = 1;
    }
    return $self->{"filemtime"};
}
# filesize: Set/retrieve the MIME content disposition size
sub filesize : method {
    local ($_, %_);
    my ($self, $filesize);
    ($self, $filesize) = @_;
    if (@_ > 1) {
        http_500 "bad size $filesize"
            unless $filesize =~ /^\d+$/;
        $filesize = encode("US-ASCII", $filesize) if is_utf8($filesize);
        $self->{"filesize"} = $filesize;
        $self->{"modified"} = 1;
    }
    return $self->{"filesize"};
}

# RFC 1864 Content-MD5
# md5: Set/retrieve the MD5 digest enable/disable flag
sub md5 : method {
    local ($_, %_);
    my ($self, $md5);
    ($self, $md5) = @_;
    if (@_ > 1) {
        $self->{"md5"} = $md5? 1: 0;
        $self->{"modified"} = 1;
    }
    return $self->{"md5"};
}

# RFC 2387 MIME multipart/related headers/properties
# related_type: Set/retrieve the multipart/related type
sub related_type : method {
    local ($_, %_);
    my ($self, $reltype);
    ($self, $reltype) = @_;
    if (@_ > 1) {
        $self->{"related_type"} = $reltype;
        $self->{"modified"} = 1;
    }
    return $self->{"related_type"};
}
# related_start: Set/retrieve the multipart/related start
sub related_start : method {
    local ($_, %_);
    my ($self, $relstart);
    ($self, $relstart) = @_;
    if (@_ > 1) {
        $self->{"related_start"} = $relstart;
        $self->{"modified"} = 1;
    }
    return $self->{"related_start"};
}

# RFC 2369/2919 Mailing Lists headers/properties
# list_id: Set/retrieve the list ID.
sub list_id : method {
    local ($_, %_);
    my ($self, $id, $phrase);
    ($self, $id, $phrase) = @_;
    if (@_ > 1) {
        # Reset it
        if (!defined $id) {
            undef $self->{"list_id"};
        # Set it
        } else {
            $self->{"list_id"} = {
                "id"        => $id,
                "phrase"    => $phrase,
            };
        }
        $self->{"modified"} = 1;
    }
    return undef if !defined $self->{"list_id"};
    $_ = "<" . ${$self->{"list_id"}}{"id"} . ">";
    if (defined ${$self->{"list_id"}}{"phrase"}) {
        $phrase = ${$self->{"list_id"}}{"phrase"};
        $phrase = quote $phrase if rfc822_phrase_need_quoting $phrase;
        $_ = "$phrase $_";
    }
    return $_;
}
# list_help: Set/retrieve the list help address
sub list_help : method {
    local ($_, %_);
    my ($self, $url);
    ($self, $url) = @_;
    $self->_add_list_url(\$self->{"list_help"}, $url)
        if @_ > 1;
    return $self->_ret_list_urls($self->{"list_help"});
}
# list_subscribe: Set/retrieve the list subscribe address
sub list_subscribe : method {
    local ($_, %_);
    my ($self, $url);
    ($self, $url) = @_;
    $self->_add_list_url(\$self->{"list_subscribe"}, $url)
        if @_ > 1;
    return $self->_ret_list_urls($self->{"list_subscribe"});
}
# list_unsubscribe: Set/retrieve the list unsubscribe address
sub list_unsubscribe : method {
    local ($_, %_);
    my ($self, $url);
    ($self, $url) = @_;
    $self->_add_list_url(\$self->{"list_unsubscribe"}, $url)
        if @_ > 1;
    return $self->_ret_list_urls($self->{"list_unsubscribe"});
}
# list_post: Set/retrieve the list post address
#   "" means "List-Post: NO"
sub list_post : method {
    local ($_, %_);
    my ($self, $url);
    ($self, $url) = @_;
    if (@_ > 1) {
        if ($url eq "") {
            $self->{"list_post"} = "";
        } else {
            $self->_add_list_url(\$self->{"list_post"}, $url);
        }
    }
    return undef if !defined $self->{"list_post"};
    return "NO" if ref $self->{"list_post"} ne "ARRAY";
    return $self->_ret_list_urls($self->{"list_post"});
}
# list_owner: Set/retrieve the list owner address
sub list_owner : method {
    local ($_, %_);
    my ($self, $url);
    ($self, $url) = @_;
    $self->_add_list_url(\$self->{"list_owner"}, $url)
        if @_ > 1;
    return $self->_ret_list_urls($self->{"list_owner"});
}
# list_archive: Set/retrieve the list archive address
sub list_archive : method {
    local ($_, %_);
    my ($self, $url);
    ($self, $url) = @_;
    $self->_add_list_url(\$self->{"list_archive"}, $url)
        if @_ > 1;
    return $self->_ret_list_urls($self->{"list_archive"});
}

# Non-standard headers
# errors_to: Set/retrieve the Errors-To: header
sub errors_to : method {
    local ($_, %_);
    my ($self, $email);
    ($self, $email) = @_;
    if (@_ > 1) {
        if (!defined $email) {
            undef $self->{"errors_to"};
        } else {
            $self->{"errors_to"} = [];
            push @{$self->{"errors_to"}}, $email;
        }
        $self->{"modified"} = 1;
    }
    return $self->{"errors_to"};
}

# precedence: Set/retrieve the precedence, mentioned in RFC 2076
#   "bulk" or "first-class"
sub precedence : method {
    local ($_, %_);
    my ($self, $precedence);
    ($self, $precedence) = @_;
    if (@_ > 1) {
        if (!defined $precedence) {
            undef $self->{"precedence"};
        } elsif ($precedence =~ /^(?:bulk|first-class)$/) {
            $precedence = encode("US-ASCII", $precedence)
                if is_utf8($precedence);
            $self->{"precedence"} = $precedence;
        } else {
            http_500 "bad precedence $precedence";
        }
        $self->{"modified"} = 1;
    }
    return $self->{"precedence"};
}

# mailer: Set/retrieve the mailer
sub mailer : method {
    local ($_, %_);
    my ($self, $mailer);
    ($self, $mailer) = @_;
    if (@_ > 1) {
        $self->{"mailer"} = $mailer;
        $self->{"modified"} = 1;
    }
    return $self->{"mailer"};
}

# any_header: Set/retrieve any header
sub any_header : method {
    local ($_, %_);
    my ($self, $name, $value, $ndx);
    ($self, $name, $value) = @_;
    # Find the index of that header
    undef $ndx;
    for ($_ = 0; $_ < @{$self->{"any_header"}}; $_++) {
        next if ${${$self->{"any_header"}}[$_]}{"name"} ne $name;
        $ndx = $_;
        last;
    }
    # Set the value
    if (@_ > 1) {
        if (defined $ndx) {
            ${${$self->{"any_header"}}[$ndx]}{"value"} = $value;
        } else {
            # Only add a defined value
            if (defined $value) {
                push @{$self->{"any_header"}}, {
                    "name"  => $name,
                    "value" => $value,
                }
            }
        }
        $self->{"modified"} = 1;
        return $value;
    # Retrieve the value
    } else {
        return ${${$self->{"any_header"}}[$ndx]}{"value"}
            if defined $ndx;
        return undef;
    }
}

# body: Set/retrieve the body
sub body : method {
    local ($_, %_);
    my ($self, $body);
    ($self, $body) = @_;
    if (@_ > 1) {
        $self->{"body"} = $body;
        $self->{"modified"} = 1;
    }
    return $self->{"body"};
}

# addpart: Add an MIME part
#   $mail is a Selima::Mail object
sub addpart : method {
    local ($_, %_);
    my ($self, $mail);
    ($self, $mail) = @_;
    if (!defined $mail) {
        $self->{"parts"} = [];
    } else {
        push @{$self->{"parts"}}, $mail;
    }
    $self->{"modified"} = 1;
    return $mail;
}

# from_file: Set the mail from a file
sub from_file : method {
    local ($_, %_);
    my ($self, $file);
    ($self, $file) = @_;
    $self->{"type"} = $MM->checktype_filename($file);
    $self->{"body"} = xfread($file);
    $self->{"modified"} = 1;
    return;
}

# as_attach: Set the mail as an attachment
sub as_attach : method {
    local ($_, %_);
    my ($self, $file, $filename);
    ($self, $file, $filename) = @_;
    $self->{"type"} = $MM->checktype_filename($file);
    $self->{"disposition"} = "attachment";
    $self->{"filename"} = defined $filename? $filename: basename($file);
    ($self->{"filemtime"}, $self->{"filesize"}) = (stat $file)[9,7];
    $self->{"body"} = xfread($file);
    $self->{"modified"} = 1;
    return $self->{"body"};
}

# as_attach_upload: Set the an attachment from $SESSION
# To be done
sub as_attach_upload : method {
    local ($_, %_);
    my ($self, $sn);
    ($self, $sn) = @_;
}

# add_attach: Add an attachment
sub add_attach : method {
    local ($_, %_);
    my ($self, $file, $filename, $attach);
    ($self, $file, $filename) = @_;
    if (!defined $file) {
        $self->{"attaches"} = [];
    } else {
        # Create the attachment
        $attach = new Selima::Mail;
        $attach->as_attach($file, $filename);
        push @{$self->{"attaches"}}, $attach;
    }
    $self->{"modified"} = 1;
    return;
}

# add_attach_upload: Add an attachment from $SESSION
# To be done
sub add_attach_upload : method {
    local ($_, %_);
    my ($self, $sn);
    ($self, $sn) = @_;
}

# send_with: Set the mail sending method
sub send_with : method {
    local ($_, %_);
    my ($self, $send_with);
    ($self, $send_with) = @_;
    # Set the value
    if (@_ > 1) {
        http_500 "you must specify a sending method"
            if !defined $send_with;
        if ($send_with eq "sendmail") {
            # Check if sendmail exists
            http_500 "/usr/sbin/sendmail missing"
                if !-e "/usr/sbin/sendmail";
            $self->{"send_with"} = $send_with;
        } elsif ($send_with eq "smtp") {
            # SMTP is always possible
            $self->{"send_with"} = $send_with;
        } else {
            http_500 "unknown sending method: $send_with";
        }
    }
    return $self->{"send_with"};
}

# output: Output the mail message
sub output : method {
    local ($_, %_);
    my ($self, $is_full_msg, $mail, $body, @headers);
    my ($content_transfer_encoding, $boundary, $md5);
    ($self, $is_full_msg) = @_;
    $is_full_msg = 1 if !defined $is_full_msg;
    # Output before
    return $self->{"output"}
        if defined $self->{"output"} && !$self->{"modified"};
    
    # Set the attachment
    $mail = $self->_get_attached_mail;
    
    # Check the message
    $self->_check if $is_full_msg;
    
    # Set the mail body
    # Set the body first, since we need to know Content-Transfer-Encoding
    # and MIME multipart boundary first
    $body = "";
    undef $content_transfer_encoding;
    # A single content
    if (    !defined $mail->{"type"}
            || $mail->{"type"} !~ /^multipart\//) {
        if (defined $mail->{"body"}) {
            $body = $mail->{"body"};
            # A text message
            if ($mail->{"type"} =~ /^text\//) {
                # Encode it
                # This piece of code shall be refined
                $body = encode($mail->{"charset"}, $body)
                    if  $mail->{"type"} eq "text/plain"
                        && !is_usascii_printable $body
                        && defined $mail->{"charset"};
                $body =~ s/\r\n/\n/g;
                # Not in US-ASCII, containing long lines, or MD5 is in use
                # encode_qp() only work with Unix "\n" text
                if (    !is_usascii_printable_text $body
                        || $body =~ /[^\r\n]{76}/
                        || $mail->{"md5"}) {
                    $body = encode_qp($body);
                    $content_transfer_encoding = "quoted-printable";
                }
                $body =~ s/\n/\r\n/g;
                $md5 = md5_base64($body) if $mail->{"md5"};
            
            # A piece of RFC-822 e-mail message
            } elsif ($mail->{"type"} =~ /^message\//) {
                # Do nothing
            
            # A piece of binary data
            } else {
                $md5 = md5_base64($body) if $mail->{"md5"};
                $body = encode_base64($body, "\r\n");
                $content_transfer_encoding = "base64";
            }
        }
    
    # A multipart MIME content
    } else {
        my (@parts, $everything);
        @parts = map $_->output(0), @{$mail->{"parts"}};
        $everything = join "\r\n", @parts;
        # Create a boundary
        do {
            $boundary = "=_";
            while (length $boundary < $mail->{"boundary_len"}) {
                $_ = int rand 3;
                if ($_ == 0) {
                    $boundary .= chr(ord "0" + int rand 10);
                } elsif ($_ == 1) {
                    $boundary .= chr(ord "A" + int rand 26);
                } else {
                    $boundary .= chr(ord "a" + int rand 26);
                }
            }
        } until $everything !~ /$boundary/;
        # Add the boundary and compose the body
        $body = join "", map "--$boundary\r\n$_\r\n", @parts;
    }
    # Ensure a CRLF is in the end
    $body =~ s/(\r\n)?$/\r\n/;
    
    @headers = qw();
    
    # RFC 822 headers
    # RFC-822 suggests the header order as:
    #  "Return-Path", "Received", "Date",  "From",  "Subject",  "Sender",
    #  "To", "cc", etc.
    # We do not set the Received: header.  It is added before mail is sent.
    # Set the Date: header
    push @headers, "Date: " . rfc822_time . "\r\n"
        if $is_full_msg;
    # Set the From: header
    if (defined $mail->{"from"}) { 
        push @headers, "From: " . $mail->_out_addrs($mail->{"from"}) . "\r\n";
    } elsif ($is_full_msg) {
        @_ = getpwuid $>;
        $_ = {
            "name"  => $_[6],
            "email" => $_[0] . "@" . fqdn,
        };
        push @headers, "From: " . $mail->_out_addr($_) . "\r\n";
    }
    # Set the Subject: header
    if (defined $mail->{"subject"}) {
        $_ = $mail->{"subject"};
        $_ = b64hdr_encode $_, $mail->{"charset"};
        push @headers, "Subject: $_\r\n";
    }
    # Set the Sender: header
    if (defined $mail->{"sender"}) {
        my $need;
        $need = 0;
        # Multiple From:
        if (@{$mail->{"from"}} > 1) {
            $need = 1;
        # Different than the only From:
        } else {
            my ($from, $sender);
            $from = ${$mail->{"from"}}[0];
            $sender = ${$mail->{"sender"}};
            if ($$from{"email"} ne $$sender{"email"}) {
                $need = 1;
            } elsif (!defined $$from{"name"} && defined $$sender{"name"}) {
                $need = 1;
            } elsif (defined $$from{"name"}) {
                if (!defined $$sender{"name"}) {
                    $need = 1;
                } elsif ($$from{"name"} ne $$sender{"name"}) {
                    $need = 1;
                }
            }
        }
        push @headers, "Sender: " . $mail->_out_addr($mail->{"sender"}) . "\r\n"
            if $need;
    }
    # Set the To: header
    push @headers, "To: " . $mail->_out_addrs($mail->{"to"}) . "\r\n"
        if defined $mail->{"to"};
    # Set the Cc: header
    push @headers, "Cc: " . $mail->_out_addrs($mail->{"cc"}) . "\r\n"
        if defined $mail->{"cc"};
    # Set the Bcc: header
    push @headers, "Bcc: " . $mail->_out_addrs($mail->{"bcc"}) . "\r\n"
        if defined $mail->{"bcc"};
    # Destination must exist (by RFC 822 4.1)
    #push @headers, "Bcc: \r\n"
    #    if  $is_full_msg
    #        && !defined $mail->{"to"}
    #        && !defined $mail->{"cc"}
    #        && !defined $mail->{"bcc"};
    # Set the Reply-To: header
    push @headers, "Reply-To: " . $mail->_out_addrs($mail->{"reply_to"}) . "\r\n"
        if defined $mail->{"reply_to"};
    # Set the Message-ID: header
    if ($is_full_msg) {
        $_ = defined $mail->{"id"}? $mail->{"id"}: $mail->_new_msgid;
        push @headers, "Message-ID: <$_>\r\n";
    }
    
    # RFC 1521 MIME headers
    # Set the MIME-Version: header
    push @headers, "MIME-Version: 1.0\r\n"
        if $is_full_msg && defined $mail->{"type"};
    # Set the Content-Type: header
    if (defined $mail->{"type"}) {
        my $type;
        $type = $mail->{"type"};
        $type = encode($mail->{"charset"}, $type)
            if is_utf8($type) && defined $mail->{"charset"};
        $type .= "; charset=" . $mail->{"charset"}
            if $type =~ /^text\// && defined $mail->{"charset"};
        # Attachment filename -- deprecated
        #if (defined $mail->{"filename"}) {
        #    $_ = $mail->{"filename"};
        #    $_ = b64hdr_encode $_, $mail->{"charset"};
        #    $_ = quote $_ if rfc1521_value_need_quoting $_;
        #    $type .= ";\r\n    name=$_";
        #}
        if ($type =~ /^multipart\//) {
            # Add type and start parameter to multipart/related
            if ($type eq "multipart/related") {
                $_ = ${$mail->{"parts"}}[0]->type
                    if !defined($_ = $mail->{"related_type"});
                $_ = encode($mail->{"charset"}, $_)
                    if is_utf8($_) && defined $mail->{"charset"};
                $type .= ";\r\n    type=\"$_\"";
                # "start" parameter is broken in most e-mail client (??? why?)
                #$_ = ${$mail->{"parts"}}[0]->id(1)
                #    if !defined($_ = $mail->{"related_start"});
                #$_ = encode($mail->{"charset"}, $_)
                #    if is_utf8($_) && defined $mail->{"charset"};
                #$type .= ";\r\n    start=\"$_\"";
               
            }
            $type .= ";\r\n    boundary=\"$boundary\"";
        }
        push @headers, "Content-Type: $type\r\n";
    }
    # Set the Content-ID: header
    # Do not generate Content-ID for complete messages.  Complete
    #   messages has Message-ID instead.
    push @headers, "Content-ID: <" . $mail->{"id"} . ">\r\n"
        if !$is_full_msg && defined $mail->{"id"};
    # Set the Content-Transfer-Encoding: header
    push @headers, "Content-Transfer-Encoding: $content_transfer_encoding\r\n"
        if defined $content_transfer_encoding;
    
    # RFC 1766 Content-Language
    push @headers, join ", ", map ln($_, LN_NAME), @{$mail->{"lang"}}
        if defined $mail->{"lang"};
    
    # RFC 1806/2183 Content-Disposition
    if (defined $mail->{"disposition"}) {
        my $disposition;
        $disposition = $mail->{"disposition"};
        if (defined $mail->{"filename"}) {
            # Note: Eudora cannot handle encoded MIME parameter values
            $_ = $mail->{"filename"};
            $_ = b64hdr_encode $_, $mail->{"charset"};
            $_ = quote $_ if rfc1521_value_need_quoting $_;
            $disposition .= ";\r\n    filename=$_";
        }
        $disposition .= ";\r\n    modification-date=\""
                . rfc822_time($mail->{"filemtime"}) . "\""
            if defined $mail->{"filemtime"};
        $disposition .= ";\r\n    size=" . $mail->{"filesize"}
            if defined $mail->{"filesize"};
        push @headers, "Content-Disposition: $disposition\r\n";
    }
    # RFC 1864 Content-MD5
    push @headers, "Content-MD5: $md5\r\n" if $mail->{"md5"};
    
    # RFC 2369/2919 Mailing Lists headers
    # Set the List-ID: header
    if (defined $mail->{"list_id"}) {
        $_ = ${$mail->{"list_id"}}{"id"};
        $_ = encode($mail->{"charset"}, $_)
            if is_utf8($_) && defined $mail->{"charset"};
        $_ = "<$_>";
        if (defined ${$mail->{"list_id"}}{"phrase"}) {
            my $phrase;
            $phrase = ${$mail->{"list_id"}}{"phrase"};
            $phrase = quote $phrase if rfc822_phrase_need_quoting $phrase;
            $phrase = b64hdr_encode $phrase, $mail->{"charset"};
            $_ = "$phrase $_";
        }
        push @headers, "List-ID: $_\r\n";
    }
    # Set the List-Help: header
    push @headers, "List-Help: "
            . $mail->_out_list_urls($mail->{"list_help"}) . "\r\n"
        if defined $mail->{"list_help"};
    # Set the List-Subscribe: header
    push @headers, "List-Subscribe: "
            . $mail->_out_list_urls($mail->{"list_subscribe"}) . "\r\n"
        if defined $mail->{"list_subscribe"};
    # Set the List-Unsubscribe: header
    push @headers, "List-Unsubscribe: "
            . $mail->_out_list_urls($mail->{"list_unsubscribe"}) . "\r\n"
        if defined $mail->{"list_unsubscribe"};
    # Set the List-Post: header
    if (defined $mail->{"list_post"}) {
        $_ = ref $mail->{"list_post"} eq "ARRAY"?
            $mail->_out_list_urls($mail->{"list_post"}): "NO";
        push @headers, "List-Post: $_\r\n";
    }
    # Set the List-Owner: header
    push @headers, "List-Owner: "
            . $mail->_out_list_urls($mail->{"list_owner"}) . "\r\n"
        if defined $mail->{"list_owner"};
    # Set the List-Archive: header
    push @headers, "List-Archive: "
            . $mail->_out_list_urls($mail->{"list_archive"}) . "\r\n"
        if defined $mail->{"list_archive"};
    
    # Set the Errors-To: header
    push @headers, "Errors-To: " . join(", ", $mail->{"errors_to"}) . "\r\n"
        if $is_full_msg && defined $mail->{"errors_to"};
    
    # Set the Precedence: header
    push @headers, "Precedence: " . $mail->{"precedence"} . "\r\n"
        if $is_full_msg && defined $mail->{"precedence"};
    
    # Set the X-Mailer: header
    if ($is_full_msg && defined $mail->{"mailer"}) {
        $_ = $mail->{"mailer"};
        $_ = encode($mail->{"charset"}, $_)
            if is_utf8($_) && defined $mail->{"charset"};
        push @headers, "X-Mailer: " . $mail->{"mailer"} . "\r\n";
    }
    
    # Compose it
    $self->{"output"} = join("", @headers) . "\r\n" . $body;
    $self->{"modified"} = 0;
    return $self->{"output"};
}

# send: Send the mail message
sub send : method {
    local ($_, %_);
    my $self;
    $self = $_[0];
    # Send the mail with Sendmail
    if ($self->{"send_with"} eq "sendmail") {
        return $self->_send_with_sendmail;
    # Send the mail with SMTP
    } elsif ($self->{"send_with"} eq "smtp") {
        return $self->_send_with_smtp;
    }
}


# _new_msgid: Obtain a new message ID.
sub _new_msgid : method {
    local ($_, %_);
    my ($sec, $msec, $sn, $fqdn);
    # Epoch time and minisecond
    $sec = int($_ = Time::HiRes::time);
    $msec = int(($_ - $sec) * 1000000);
    # A random serial number
    do {
        $sn = int rand 10000;
    } until !exists $Mail_MSGIDS{$sn};
    $Mail_MSGIDS{$sn} = 1;
    # Compose it
    return sprintf "%10d.%06d.%05d.%04d.selima@%s",
        $sec, $msec, $$, $sn, fqdn;
}

# _get_attached_mail: Get the mail with its attachment
#   Actually, this will convert the mail to multipart/mixed
#   and add the attachments
sub _get_attached_mail : method {
    local ($_, %_);
    my ($self, $mail);
    $self = $_[0];
    # Make a copy of myself
    $mail = $self;
    
    # Return myself if there is no attachment
    return $mail if @{$mail->{"attaches"}} == 0;
    
    # Not multipart/mixed -- convert to multipart/mixed
    unless (defined $mail->{"type"} && $mail->{"type"} eq "multipart/mixed") {
        # Pass the content to the body part
        my $body;
        $body = new Selima::Mail;
        $body->{"charset"} = $mail->{"charset"};
        $body->{"type"} = $mail->{"type"};
        $body->{"id"} = $mail->{"id"};
        $body->{"lang"} = $mail->{"lang"};
        $body->{"md5"} = $mail->{"md5"};
        # Set the body
        # The origin is multipart/xxx
        if (    defined $mail->{"type"}
                && $mail->{"type"} =~ /^multipart\//) {
            $body->{"parts"} = $mail->{"parts"};
        } else {
            $body->{"body"} = $mail->{"body"};
        }
        # Reset these values
        $mail->{"parts"} = [];
        undef $mail->{"body"};
        $mail->{"type"} = "multipart/mixed";
        undef $mail->{"id"};
        undef $mail->{"lang"};
        $mail->{"md5"} = 0;
        $mail->addpart($body);
    }
    
    # Add each attachment
    $mail->addpart($_) foreach @{$mail->{"attaches"}};
    
    return $mail;
}

# _set_addr: Set an address
sub _set_addr : method {
    local ($_, %_);
    my ($self, $addr, $email, $name);
    ($self, $addr, $email, $name) = @_;
    # Reset it
    if (!defined $email) {
        undef $$addr;
    # Set it
    } else {
        $$addr = {
            "name"  => $name,
            "email" => $email,
        };
    }
    $self->{"modified"} = 1;
}
# _add_addr: Add an address to an address list
sub _add_addr : method {
    local ($_, %_);
    my ($self, $list, $email, $name);
    ($self, $list, $email, $name) = @_;
    # Reset it
    if (!defined $email) {
        undef $$list;
    # Add it
    } else {
        $$list = [] if !defined $$list || ref $$list ne "ARRAY";
        push @$$list, {
            "name"  => $name,
            "email" => $email,
        };
    }
    $self->{"modified"} = 1;
}

# _ret_addr: Return an address
sub _ret_addr : method {
    local ($_, %_);
    my ($self, $addr, $name);
    ($self, $addr) = @_;
    return undef if !defined $addr;
    return $$addr{"email"} if !defined $$addr{"name"};
    $name = $$addr{"name"};
    $name = quote $name if rfc822_phrase_need_quoting $name;
    return sprintf "%s <%s>", $name, $$addr{"email"};
}
# _ret_addrs: Return a list of addresses
sub _ret_addrs : method {
    local ($_, %_);
    my ($self, $list);
    ($self, $list) = @_;
    return undef if !defined $list;
    return join ", ", map $self->_ret_addr($_), @$list;
}

# _out_addr: Output an address
sub _out_addr : method {
    local ($_, %_);
    my ($self, $addr, $name, $email);
    ($self, $addr) = @_;
    $email = $$addr{"email"};
    $email = encode($self->{"charset"}, $email)
        if is_utf8($email) && defined $self->{"charset"};
    return $email if !defined $$addr{"name"};
    $name = $$addr{"name"};
    $name = quote $name if rfc822_phrase_need_quoting $name;
    $name = b64hdr_encode $name, $self->{"charset"};
    return sprintf "%s <%s>", $name, $email;
}
# _out_addrs: Output a list of addresses
sub _out_addrs : method {
    local ($_, %_);
    my ($self, $list);
    ($self, $list) = @_;
    return join ",\r\n    ", map $self->_out_addr($_), @$list;
}

# _add_list_url:Add a list URL to a list URL list
sub _add_list_url : method {
    local ($_, %_);
    my ($self, $list, $url);
    ($self, $list, $url) = @_;
    # Reset it
    if (!defined $url) {
        undef $$list;
    # Add it
    } else {
        $$list = [] if !defined $$list || ref $$list ne "ARRAY";
        push @$$list, $url;
    }
    $self->{"modified"} = 1;
}
# _ret_list_urls: Return a list of list URLs
sub _ret_list_urls : method {
    local ($_, %_);
    my ($self, $list);
    ($self, $list) = @_;
    return join ", ", map "<$_>", @$list;
}
# _out_list_urls: Output a list of list URLs
sub _out_list_urls : method {
    local ($_, %_);
    my ($self, $list);
    ($self, $list) = @_;
    @_ = @$list;
    if (defined $self->{"charset"}) {
        foreach (@_) {
            $_ = encode($self->{"charset"}, $_) if is_utf8($_);
        }
    }
    return join ",\r\n    ", map "<$_>", @_;
}
# _out_trace: Output the trace information (the Received: header)
# See RFC 2821 4.4 Trace Information
sub _out_trace : method {
    local ($_, %_);
    my ($self, @trace_info);
    my ($from_address_literal,  $from_tcpinfo_domain, $from_tcp_info);
    my ($by_address_literal, $by_domain, $by_tcpinfo_domain, $by_tcp_info);
    $self = $_[0];
    # The trace information
    @trace_info = qw();
    
    # From-domain
    # mod_perl: use Apache->request->connection->remote_ip
    $from_address_literal = $IS_MODPERL? ($IS_MP2?
        Apache2::RequestUtil->request->connection->remote_ip:
        Apache->request->connection->remote_ip):
        $ENV{"REMOTE_ADDR"};
    $from_tcpinfo_domain = gethostbyaddr inet_aton($from_address_literal), AF_INET;
    if (!defined $from_tcpinfo_domain) {
        $from_tcp_info = sprintf "[%s]", $from_address_literal;
    } else {
        $from_tcp_info = sprintf "%s [%s]",
            $from_tcpinfo_domain, $from_address_literal;
    }
    push @trace_info, "from webclient ($from_tcp_info)";
    
    # The invoking user, as a from comment
    if (!defined get_login_sn) {
        $_ = "invoked by anonymous web user"
            . " country " . country_lookup;
    } else {
        $_ = "invoked by web user " . get_login_id
            . " S/N " . get_login_sn
            . " country " . country_lookup;
    }
    push @trace_info, "($_)";
    
    # By-domain
    # Apache implementation
    $by_address_literal = is_apache? $ENV{"SERVER_ADDR"}:
    # Microsoft IIS implementation
        is_iis? $ENV{"LOCAL_ADDR"}:
    # Else, do DNS query
        inet_ntoa(scalar gethostbyname $ENV{"SERVER_NAME"});
    if (exists $ENV{"HTTP_HOST"}) {
        $by_domain = $ENV{"HTTP_HOST"};
        $by_domain =~ s/:\d+$//;
    } else {
        $by_domain = $by_address_literal;
    }
    $by_tcpinfo_domain = gethostbyaddr inet_aton($by_address_literal), AF_INET;
    if (!defined $by_tcpinfo_domain) {
        $by_tcp_info = sprintf "[%s]", $by_address_literal;
    } else {
        $by_tcp_info = sprintf "%s [%s]",
            $by_tcpinfo_domain, $by_address_literal;
    }
    push @trace_info, sprintf("by %s (%s)", $by_domain, $by_tcp_info);
    
    # VIA Link and WITH Protocol
    push @trace_info, "via TCP with HTTP";
    
    # For recipients
    push @trace_info, "for " . join(" ", map "<$_>", @_)
        if (@_ = $self->_get_rcpts) > 0;
    
    return sprintf("Received: %s ;\r\n\t%s\r\n",
        join("\r\n\t", @trace_info), rfc822_time);
}

# _check: Check if it is ready to be output
# Refer to RFC 822
sub _check : method {
    local ($_, %_);
    my $self;
    $self = $_[0];
    # When no valid From: exists, default to the current user of the running process
    # Check if a valid Sender: exists with multiple From:
    http_500 "Multiple From: without a valid Sender: (RFC-822)"
        if  defined $self->{"from"}
            && @{$self->{"from"}} > 1
            && !defined $self->{"sender"};
    # Check if valid contents exist
    http_500 "MIME Multipart without any valid part"
        if  defined $self->{"type"}
            && $self->{"type"} =~ /^multipart\//
            && $self->{"parts"} == 0;
}

# _get_sender: Collect the sender
sub _get_sender : method {
    local ($_, %_);
    my ($self, $fallback);
    ($self, $fallback) = @_;
    $fallback = 0 if !defined $fallback;
    # MAIL FROM: specified
    return $self->{"mail_from"}
        if defined $self->{"mail_from"};
    # Sender specified
    return ${$self->{"sender"}}{"email"}
        if defined $self->{"sender"};
    # Obtain the sender from From:
    return ${${$self->{"from"}}[0]}{"email"}
        if defined $self->{"from"};
    # Nothing left
    return undef if !$fallback;
    # Use the current user
    return (getpwuid $>)[0] . "@" . fqdn;
}

# _get_rcpts: Collect the recipients list
sub _get_rcpts : method {
    local ($_, %_);
    my ($self, @rcpts);
    $self = $_[0];
    # Recipients specified
    return @{$self->{"rcpt_to"}}
        if defined $self->{"rcpt_to"};
    
    # Obtain the recipients from To:, Cc: and Bcc:
    @rcpts = qw();
    %_ = qw();
    @_ = qw();
    push @_, @{$self->{"to"}} if defined $self->{"to"};
    push @_, @{$self->{"cc"}} if defined $self->{"cc"};
    push @_, @{$self->{"bcc"}} if defined $self->{"bcc"};
    foreach (@_) {
        next if exists $_{$$_{"email"}};
        push @rcpts, $$_{"email"};
        $_{$$_{"email"}} = 1;
    }
    return @rcpts;
}

# _send_with_sendmail: Send the mail with Sendmail
sub _send_with_sendmail : method {
    local ($_, %_);
    my ($self, $sender, @rcpts, $SENDMAIL);
    $self = $_[0];
    # Get the sender
    $sender = $self->_get_sender;
    # Collect the Recipients list
    @rcpts = $self->_get_rcpts;
    # No recipients found
    http_500 "No recipients found\n"
        if @rcpts == 0;
    
    # Obtain the mail content
    $_ = $self->_out_trace . $self->output;
    # Sendmail must escape "."s on a line.  See RFC 821 SMTP 4.5.2
    s/^(\.+\r)/.$1/gm;
    
    # Send with Sendmail
    @_ = qw(/usr/sbin/sendmail -odb);
    push @_, ("-f", $sender) if defined $sender;
    push @_, @rcpts;
    open $SENDMAIL, "|-", @_            or http_500 $_[0] . ": $!";
    print $SENDMAIL $_                  or http_500 $_[0] . ": $!";
    close $SENDMAIL                     or http_500 $_[0] . ": $!";
    return;
}

# _send_with_smtp: Send the mail with SMTP
sub _send_with_smtp : method {
    local ($_, %_);
    my ($self, $sender, @rcpts, $SMTP);
    $self = $_[0];
    # Get the sender
    $sender = $self->_get_sender(1);
    # Collect the Recipients list
    @rcpts = $self->_get_rcpts;
    # No recipients found
    http_500 "No recipients found\n"
        if @rcpts == 0;
    
    # Obtain the mail content
    $_ = $self->_out_trace . $self->output;
    # SMTP must escape lines with leading "."s.  See RFC 821 SMTP 4.5.2
    # Net::SMTP does this for me.
    
    # Send with SMTP
    $SMTP = new Net::SMTP(SMTP_HOST)        or http_500 "$!";
    $SMTP->mail($sender, Size=>length $_)   or http_500 "MAIL FROM:<$sender>: " . $SMTP->code . " " . $SMTP->message;
    foreach (@rcpts) {
        $SMTP->to($_)                       or http_500 "RCPT TO:<$_>:: " . $SMTP->code . " " . $SMTP->message;
    }
    $SMTP->data                             or http_500 "DATA: " . $SMTP->code . " " . $SMTP->message;
    $SMTP->datasend($_)                     or http_500 "DATA: " . $SMTP->code . " " . $SMTP->message;
    $SMTP->dataend($_)                      or http_500 "DATA: " . $SMTP->code . " " . $SMTP->message;
    $SMTP->quit                             or http_500 "QUIT: " . $SMTP->code . " " . $SMTP->message;
    return;
}

#######################
# Below are Functions #
#######################
# quote: Quote a text string
#   Quoting is REQUIRED for CR and \ and ", by RFC 822 3.4.1    # " gettext
sub quote($) {
    local ($_, %_);
    $_ = $_[0];
    s/\\/\\\\/g;
    s/"/\\"/g;
    s/\r/\\\r/g;
    return "\"$_\"";
}
# rfc822_phrase_need_quoting: Whether a phrase need to be quoted by RFC-822
sub rfc822_phrase_need_quoting($) {
    return $_[0] =~ /[()<>@,;:\\"\.\[\]\x01-\x1F\x7F]/;         # " gettext
}
# rfc1521_value_need_quoting: Whether a value need to be quoted by RFC-1521
sub rfc1521_value_need_quoting($) {
    return $_[0] =~ /[()<>@,;:\\"\/\[\]\?= \x01-\x1F\x7F]/;     # " gettext
}
# b64hdr_encode: Encode a piece of header text with Base-64
#   Refer to RFC-1522 4.1
sub b64hdr_encode($$) {
    local ($_, %_);
    my ($text, $charset);
    ($text, $charset) = @_;
    # US-ASCII printable -- no need to encode it
    return $text if is_usascii_printable $text;
    # No desired character set available
    return $text if !defined $charset;
    # Successfully encoded
    return "=?$charset?B?" . encode_base64($_, "") . "?="
        if eval { $_ = encode($charset, $text, FB_CROAK); 1; };
    # Else -- send in UTF-8
    $_ = encode("UTF-8", $text, FB_CROAK);
    return "=?UTF-8?B?" . encode_base64($_, "") . "?=";
}
# rfc822_time: Output the time as RFC-822
#   Day should be displayed as one digit, without the padding space.
sub rfc822_time(;$) {
    local ($_, %_);
    $_ = $_[0];
    $_ = time if !defined $_;
    return sprintf time2str("%a, %%d %b %Y %X %z", $_), (localtime $_)[3];
}

return 1;