1418 lines
44 KiB
Perl
1418 lines
44 KiB
Perl
# 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;
|