mirror of
https://github.com/webmin/webmin.git
synced 2026-06-05 21:00:22 +01:00
c68d03b211
Refresh stale Maildir and sorted mailbox indexes when messages disappear, avoid rendering missing messages, and keep IMAP sort indexes in sync with mailbox count changes.
3314 lines
84 KiB
Perl
Executable File
3314 lines
84 KiB
Perl
Executable File
# boxes-lib.pl
|
|
# Functions to parsing user mail files
|
|
|
|
use POSIX;
|
|
use Fcntl;
|
|
if ($userconfig{'date_tz'} || $config{'date_tz'}) {
|
|
# Set the timezone for all date calculations, and force a conversion
|
|
# now as in some cases the first one fails!
|
|
$ENV{'TZ'} = $userconfig{'date_tz'} ||
|
|
$config{'date_tz'};
|
|
strftime('%H:%M', localtime(time()));
|
|
}
|
|
use Time::Local;
|
|
|
|
$dbm_index_min = 1000000;
|
|
$dbm_index_version = 3;
|
|
|
|
# supports_tnef_module()
|
|
# Returns 1 if the Convert::TNEF module is available for decoding winmail.dat
|
|
my $supports_tnef_module;
|
|
sub supports_tnef_module
|
|
{
|
|
if (!defined($supports_tnef_module)) {
|
|
$supports_tnef_module = eval { require Convert::TNEF; 1; } ? 1 : 0;
|
|
}
|
|
return $supports_tnef_module;
|
|
}
|
|
|
|
# decode_tnef_attachment(&attach)
|
|
# Expands a TNEF attachment into a list of normal attachments, or returns
|
|
# an error string if decoding is not possible
|
|
sub decode_tnef_attachment
|
|
{
|
|
my ($attach) = @_;
|
|
my @rv;
|
|
return (undef, "Convert::TNEF module not installed")
|
|
if (!&supports_tnef_module());
|
|
|
|
my $tempdir = &transname();
|
|
mkdir($tempdir, 0700) || return (undef, $!);
|
|
|
|
# Only try to de-privilege the parser when we are currently fully root;
|
|
# In Usermin or already-switched contexts, just decode as the current user
|
|
my $parse_user = !$< && !$> ? &get_mail_parse_user($attach) : undef;
|
|
my $tnef;
|
|
if ($parse_user) {
|
|
# Convert::TNEF may create temp files under output_dir, so hand it a
|
|
# private directory owned by the mailbox user and run the parser as
|
|
# that user instead of root
|
|
local $main::mail_open_user = $parse_user;
|
|
my @uinfo = &get_switch_user_info();
|
|
@uinfo || return (undef, "Mail open user $parse_user does not exist");
|
|
&set_ownership_permissions($uinfo[2], $uinfo[3], 0700, $tempdir);
|
|
my $switched = &switch_to_mail_user();
|
|
my $io;
|
|
my $ok = eval {
|
|
open($io, "<", \$attach->{'data'}) || die "$!";
|
|
binmode($io);
|
|
$tnef = Convert::TNEF->read($io,
|
|
{ 'output_dir' => $tempdir,
|
|
'buffer_size' => &get_buffer_size() });
|
|
close($io) || die "$!";
|
|
1;
|
|
};
|
|
if ($switched) {
|
|
# Restore root after decoding so the rest of the mailbox code
|
|
# keeps running with its original privileges
|
|
$) = 0;
|
|
$> = 0;
|
|
}
|
|
return (undef, $@) if (!$ok);
|
|
}
|
|
else {
|
|
my $io;
|
|
if (!open($io, "<", \$attach->{'data'})) {
|
|
return (undef, $!);
|
|
}
|
|
binmode($io);
|
|
$tnef = eval {
|
|
Convert::TNEF->read($io,
|
|
{ 'output_dir' => $tempdir,
|
|
'buffer_size' => &get_buffer_size() })
|
|
};
|
|
close($io);
|
|
}
|
|
if ($@) {
|
|
return (undef, $@);
|
|
}
|
|
if (!$tnef) {
|
|
return (undef, $Convert::TNEF::errstr ||
|
|
"failed to decode winmail.dat");
|
|
}
|
|
foreach my $ta ($tnef->attachments) {
|
|
my $fn = $ta->longname() || $ta->name();
|
|
$fn =~ s/\x00+$// if (defined($fn));
|
|
my $data = $ta->data();
|
|
next if (!defined($data));
|
|
my $ct = $fn ? &guess_mime_type($fn)
|
|
: "application/octet-stream";
|
|
push(@rv,
|
|
{ 'type' => $ct,
|
|
'header' => { 'content-type' => $ct },
|
|
'headers' => [ [ 'Content-Type', $ct ] ],
|
|
'filename' => $fn,
|
|
'data' => $data });
|
|
}
|
|
$tnef->purge();
|
|
return (\@rv, undef);
|
|
}
|
|
|
|
# get_mail_parse_user(&mail-or-attach)
|
|
# Returns the Unix user, if any, that should be used for unsafe mail parsing
|
|
sub get_mail_parse_user
|
|
{
|
|
my ($obj) = @_;
|
|
while ($obj) {
|
|
return $obj->{'open_user'} if ($obj->{'open_user'});
|
|
$obj = $obj->{'parent'};
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
# list_mails(user|file, [start], [end])
|
|
# Returns a subset of mail from a mbox format file
|
|
sub list_mails
|
|
{
|
|
local (@rv, $h, $done);
|
|
my %index;
|
|
my $umf = &user_mail_file($_[0]);
|
|
&open_as_mail_user(MAIL, $umf) || &error("Failed to open $umf : $!");
|
|
&build_dbm_index($_[0], \%index);
|
|
local ($start, $end);
|
|
local $isize = $index{'mailcount'};
|
|
if (@_ == 1 || !defined($_[1]) && !defined($_[2])) {
|
|
$start = 0; $end = $isize-1;
|
|
}
|
|
elsif ($_[2] < 0) {
|
|
$start = $isize+$_[2]-1; $end = $isize+$_[1]-1;
|
|
$start = $start<0 ? 0 : $start;
|
|
}
|
|
else {
|
|
$start = $_[1]; $end = $_[2];
|
|
$end = $isize-1 if ($end >= $isize);
|
|
}
|
|
$rv[$isize-1] = undef if ($isize); # force array to right size
|
|
local $dash = &dash_mode($_[0]);
|
|
$start = 0 if ($start < 0);
|
|
for($i=$start; $i<=$end; $i++) {
|
|
# Seek to mail position
|
|
local @idx = split(/\0/, $index{$i});
|
|
local $pos = $idx[0];
|
|
local $startline = $idx[1];
|
|
seek(MAIL, $pos, 0);
|
|
|
|
# Read the mail
|
|
local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, 0);
|
|
$mail->{'line'} = $startline;
|
|
$mail->{'eline'} = $startline + $mail->{'lines'} - 1;
|
|
$mail->{'idx'} = $i;
|
|
# ID is position in file and message ID
|
|
$mail->{'id'} = $pos." ".$i." ".$startline." ".
|
|
substr($mail->{'header'}->{'message-id'}, 0, 255);
|
|
$rv[$i] = $mail;
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
# select_mails(user|file, &ids, headersonly)
|
|
# Returns a list of messages from an mbox with the given IDs. The ID contains
|
|
# the file offset, message number, line and message ID, and the former is used
|
|
# if valid.
|
|
sub select_mails
|
|
{
|
|
local ($file, $ids, $headersonly) = @_;
|
|
local @rv;
|
|
|
|
local (@rv);
|
|
my %index;
|
|
local $gotindex;
|
|
|
|
local $umf = &user_mail_file($file);
|
|
local $dash = &dash_mode($umf);
|
|
&open_as_mail_user(MAIL, $umf) || &error("Failed to open $umf : $!");
|
|
foreach my $i (@$ids) {
|
|
local ($pos, $idx, $startline, $wantmid) = split(/ /, $i);
|
|
|
|
# Go to where the mail is supposed to be, and check if any starts there
|
|
seek(MAIL, $pos, 0);
|
|
local $ll = <MAIL>;
|
|
local $fromok = $ll !~ /^From\s+(\S+).*\d+\r?\n/ ||
|
|
($1 eq '-' && !$dash) ? 0 : 1;
|
|
print DEBUG "seeking to $pos in $umf, got $ll";
|
|
if (!$fromok) {
|
|
# Oh noes! Need to find it
|
|
if (!$gotindex++) {
|
|
&build_dbm_index($file, \%index);
|
|
}
|
|
$pos = undef;
|
|
while(my ($k, $v) = each %index) {
|
|
if (int($k) eq $k) {
|
|
my ($p, $line, $subject, $from, $mid)=
|
|
split(/\0/, $v);
|
|
if ($mid eq $wantmid) {
|
|
# Found it!
|
|
$pos = $p;
|
|
$idx = $k;
|
|
$startline = $line;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if (defined($pos)) {
|
|
# Now we can read
|
|
seek(MAIL, $pos, 0);
|
|
local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, $headersonly);
|
|
$mail->{'line'} = $startline;
|
|
$mail->{'eline'} = $startline + $mail->{'lines'} - 1;
|
|
$mail->{'idx'} = $idx;
|
|
$mail->{'id'} = "$pos $idx $startline $wantmid";
|
|
push(@rv, $mail);
|
|
}
|
|
else {
|
|
push(@rv, undef); # Mail is gone?
|
|
}
|
|
}
|
|
close(MAIL);
|
|
return @rv;
|
|
}
|
|
|
|
# idlist_mails(user|file)
|
|
# Returns a list of IDs in some mbox
|
|
sub idlist_mails
|
|
{
|
|
my %index;
|
|
local $idlist = &build_dbm_index($_[0], \%index);
|
|
return @$idlist;
|
|
}
|
|
|
|
# search_mail(user, field, match)
|
|
# Returns an array of messages matching some search
|
|
sub search_mail
|
|
{
|
|
return &advanced_search_mail($_[0], [ [ $_[1], $_[2] ] ], 1);
|
|
}
|
|
|
|
# advanced_search_mail(user|file, &fields, andmode, [&limits], [headersonly])
|
|
# Returns an array of messages matching some search
|
|
sub advanced_search_mail
|
|
{
|
|
local (%index, @rv, $i);
|
|
local $dash = &dash_mode($_[0]);
|
|
local @possible; # index positions of possible mails
|
|
local $possible_certain = 0; # is possible list authoratative?
|
|
local ($min, $max);
|
|
local $umf = &user_mail_file($_[0]);
|
|
&open_as_mail_user(MAIL, $umf) || &error("Failed to open $umf : $!");
|
|
|
|
# We have a DBM index .. if the search includes the from and subject
|
|
# fields, scan it first to cut down on the total time
|
|
&build_dbm_index($_[0], \%index);
|
|
|
|
# Check which fields are used in search
|
|
local @dbmfields = grep { $_->[0] eq 'from' ||
|
|
$_->[0] eq 'subject' } @{$_[1]};
|
|
local $alldbm = (scalar(@dbmfields) == scalar(@{$_[1]}));
|
|
|
|
$min = 0;
|
|
$max = $index{'mailcount'}-1;
|
|
if ($_[3] && $_[3]->{'latest'}) {
|
|
$min = $max - $_[3]->{'latest'};
|
|
}
|
|
|
|
# Only check DBM if it contains some fields, and if it contains all
|
|
# fields when in 'or' mode.
|
|
if (@dbmfields && ($alldbm || $_[2])) {
|
|
# Scan the DBM to build up a list of 'possibles'
|
|
for($i=$min; $i<=$max; $i++) {
|
|
local @idx = split(/\0/, $index{$i});
|
|
local $fake = { 'header' => { 'from', $idx[2],
|
|
'subject', $idx[3] } };
|
|
local $m = &mail_matches(\@dbmfields, $_[2], $fake);
|
|
push(@possible, $i) if ($m);
|
|
}
|
|
$possible_certain = $alldbm;
|
|
}
|
|
else {
|
|
# None of the DBM fields are in the search .. have to scan all
|
|
@possible = ($min .. $max);
|
|
}
|
|
|
|
# Need to scan through possible messages to find those that match
|
|
local $headersonly = !&matches_needs_body($_[1]);
|
|
foreach $i (@possible) {
|
|
# Seek to mail position
|
|
local @idx = split(/\0/, $index{$i});
|
|
local $pos = $idx[0];
|
|
local $startline = $idx[1];
|
|
seek(MAIL, $pos, 0);
|
|
|
|
# Read the mail
|
|
local $mail = &read_mail_fh(MAIL, $dash ? 2 : 1, $headersonly);
|
|
$mail->{'line'} = $startline;
|
|
$mail->{'eline'} = $startline + $mail->{'lines'} - 1;
|
|
$mail->{'idx'} = $i;
|
|
$mail->{'id'} = $pos." ".$i." ".$startline." ".
|
|
substr($mail->{'header'}->{'message-id'}, 0, 255);
|
|
push(@rv, $mail) if ($possible_certain ||
|
|
&mail_matches($_[1], $_[2], $mail));
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
# build_dbm_index(user|file, &index)
|
|
# Updates a reference to a DBM hash that indexes the given mail file.
|
|
# Hash contains keys 0, 1, 2 .. each of which has a value containing the
|
|
# position of the mail in the file, line number, subject, sender and message ID.
|
|
# Special key lastchange = time index was last updated
|
|
# mailcount = number of messages in index
|
|
# version = index format version
|
|
# Returns a list of all IDs
|
|
sub build_dbm_index
|
|
{
|
|
local ($user, $index, $noperm) = @_;
|
|
local $ifile = &user_index_file($user);
|
|
local $umf = &user_mail_file($user);
|
|
local @st = stat($umf);
|
|
if (!defined($noperm)) {
|
|
# Use global override setting
|
|
$noperm = $no_permanent_index;
|
|
}
|
|
if ($noperm && &has_dbm_index($user)) {
|
|
# Index already exists, so use it
|
|
$noperm = 0;
|
|
}
|
|
if (!$noperm) {
|
|
dbmopen(%$index, $ifile, 0600);
|
|
}
|
|
|
|
# Read file of IDs
|
|
local $idsfile = $ifile.".ids";
|
|
local @ids;
|
|
local $idschanged;
|
|
if (!$noperm && open(IDSFILE, "<", $idsfile)) {
|
|
@ids = <IDSFILE>;
|
|
chop(@ids);
|
|
close(IDSFILE);
|
|
}
|
|
|
|
if (scalar(@ids) != $index->{'mailcount'}) {
|
|
# Build for first time
|
|
print DEBUG "need meta-index rebuild for $user ",scalar(@ids)," != ",$index->{'mailcount'},"\n";
|
|
@ids = ( );
|
|
while(my ($k, $v) = each %$index) {
|
|
if ($k eq int($k) && $k < $index->{'mailcount'}) {
|
|
local ($pos, $line, $subject, $sender, $mid) =
|
|
split(/\0/, $v);
|
|
$ids[$k] = $pos." ".$k." ".$line." ".$mid;
|
|
}
|
|
elsif ($k >= $index->{'mailcount'}) {
|
|
# Old crap that is off the end
|
|
delete($index->{$k});
|
|
}
|
|
}
|
|
$index->{'mailcount'} = scalar(@ids); # Now known for sure
|
|
$idschanged = 1;
|
|
}
|
|
|
|
if (!@st ||
|
|
$index->{'lastchange'} < $st[9] ||
|
|
$index->{'lastsize'} != $st[7] ||
|
|
$st[7] < $dbm_index_min ||
|
|
$index->{'version'} != $dbm_index_version) {
|
|
# The mail file is newer than the index, or we are always re-indexing
|
|
local $fromok = 1;
|
|
local ($ll, @idx);
|
|
local $dash = &dash_mode($umf);
|
|
if ($st[7] < $dbm_index_min ||
|
|
$index->{'version'} != $dbm_index_version) {
|
|
$fromok = 0; # Always re-index
|
|
&open_as_mail_user(IMAIL, $umf);
|
|
}
|
|
else {
|
|
if (&open_as_mail_user(IMAIL, $umf)) {
|
|
# Check the last 100 messages (at most), to see if
|
|
# the mail file has been truncated, had mails deleted,
|
|
# or re-written.
|
|
local $il = $index->{'mailcount'}-1;
|
|
local $i;
|
|
for($i=($il>100 ? 100 : $il); $i>=0; $i--) {
|
|
@idx = split(/\0/, $index->{$il-$i});
|
|
seek(IMAIL, $idx[0], 0);
|
|
$ll = <IMAIL>;
|
|
$fromok = 0 if ($ll !~ /^From\s+(\S+).*\d+\r?\n/ ||
|
|
($1 eq '-' && !$dash));
|
|
}
|
|
}
|
|
else {
|
|
$fromok = 0; # No mail file yet
|
|
}
|
|
}
|
|
local ($pos, $lnum, $istart);
|
|
if ($index->{'mailcount'} && $fromok && $st[7] > $idx[0]) {
|
|
# Mail file seems to have gotten bigger, most likely
|
|
# because new mail has arrived ... only reindex the new mails
|
|
print DEBUG "re-indexing from $idx[0]\n";
|
|
$pos = $idx[0] + length($ll);
|
|
$lnum = $idx[1] + 1;
|
|
$istart = $index->{'mailcount'};
|
|
}
|
|
else {
|
|
# Mail file has changed in some other way ... do a rebuild
|
|
# of the whole index
|
|
print DEBUG "totally re-indexing\n";
|
|
$istart = 0;
|
|
$pos = 0;
|
|
$lnum = 0;
|
|
seek(IMAIL, 0, 0);
|
|
@ids = ( );
|
|
$idschanged = 1;
|
|
%$index = ( );
|
|
}
|
|
local ($doingheaders, @nidx);
|
|
while(<IMAIL>) {
|
|
if (/^From\s+(\S+).*\d+\r?\n/ && ($1 ne '-' || $dash)) {
|
|
@nidx = ( $pos, $lnum );
|
|
$idschanged = 1;
|
|
push(@ids, $pos." ".$istart." ".$lnum);
|
|
$index->{$istart++} = join("\0", @nidx);
|
|
$doingheaders = 1;
|
|
}
|
|
elsif ($_ eq "\n" || $_ eq "\r\n") {
|
|
$doingheaders = 0;
|
|
}
|
|
elsif ($doingheaders && /^From:\s*(.{0,255})/i) {
|
|
$nidx[2] = $1;
|
|
$index->{$istart-1} = join("\0", @nidx);
|
|
}
|
|
elsif ($doingheaders && /^Subject:\s*(.{0,255})/i) {
|
|
$nidx[3] = $1;
|
|
$index->{$istart-1} = join("\0", @nidx);
|
|
}
|
|
elsif ($doingheaders && /^Message-ID:\s*(.{0,255})/i) {
|
|
$nidx[4] = $1;
|
|
$index->{$istart-1} = join("\0", @nidx);
|
|
$ids[$#ids] .= " ".$1;
|
|
}
|
|
$pos += length($_);
|
|
$lnum++;
|
|
}
|
|
close(IMAIL);
|
|
$index->{'lastchange'} = time();
|
|
$index->{'lastsize'} = $st[7];
|
|
$index->{'mailcount'} = $istart;
|
|
$index->{'version'} = $dbm_index_version;
|
|
}
|
|
|
|
# Write out IDs file, if needed
|
|
if ($idschanged && !$noperm) {
|
|
open(IDSFILE, ">", $idsfile);
|
|
foreach my $id (@ids) {
|
|
print IDSFILE $id,"\n";
|
|
}
|
|
close(IDSFILE);
|
|
}
|
|
|
|
return \@ids;
|
|
}
|
|
|
|
# has_dbm_index(user|file)
|
|
# Returns 1 if a DBM index exists for some user or file
|
|
sub has_dbm_index
|
|
{
|
|
local $ifile = &user_index_file($_[0]);
|
|
foreach my $ext (".dir", ".pag", ".db") {
|
|
return 1 if (-r $ifile.$ext);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
# delete_dbm_index(user|file)
|
|
# Deletes all DBM indexes for a user or file
|
|
sub delete_dbm_index
|
|
{
|
|
local $ifile = &user_index_file($_[0]);
|
|
foreach my $ext (".dir", ".pag", ".db") {
|
|
&unlink_file($ifile.$ext);
|
|
}
|
|
}
|
|
|
|
# empty_mail(user|file)
|
|
# Truncate a mail file to nothing
|
|
sub empty_mail
|
|
{
|
|
local ($user) = @_;
|
|
local $umf = &user_mail_file($user);
|
|
local $ifile = &user_index_file($user);
|
|
&open_as_mail_user(TRUNC, ">$umf") || &error("Failed to open $umf : $!");
|
|
close(TRUNC);
|
|
|
|
# Set index size to 0 (if there is one)
|
|
if (&has_dbm_index($user)) {
|
|
local %index;
|
|
dbmopen(%index, $ifile, 0600);
|
|
$index{'mailcount'} = 0;
|
|
$index{'lastchange'} = time();
|
|
dbmclose(%index);
|
|
}
|
|
}
|
|
|
|
# count_mail(user|file)
|
|
# Returns the number of messages in some mail file
|
|
sub count_mail
|
|
{
|
|
my %index;
|
|
&build_dbm_index($_[0], \%index);
|
|
return $index{'mailcount'};
|
|
}
|
|
|
|
# parse_mail(&mail, [&parent], [savebody], [keep-cr])
|
|
# Extracts the attachments from the mail body
|
|
sub parse_mail
|
|
{
|
|
return if ($_[0]->{'parsed'}++);
|
|
local $ct = $_[0]->{'header'}->{'content-type'};
|
|
local (@attach, $h, $a);
|
|
if ($ct =~ /boundary="([^"]+)"/i || $ct =~ /boundary=([^;\s]+)/i) {
|
|
# Multipart MIME message
|
|
local $bound = "--".$1;
|
|
local @lines = $_[3] ? split(/\n/, $_[0]->{'body'})
|
|
: split(/\r?\n/, $_[0]->{'body'});
|
|
local $l;
|
|
local $max = @lines;
|
|
while($l < $max && $lines[$l++] ne $bound) {
|
|
# skip to first boundary
|
|
}
|
|
while(1) {
|
|
# read attachment headers
|
|
local (@headers, $attach);
|
|
while($lines[$l]) {
|
|
$attach->{'raw'} .= $lines[$l]."\n";
|
|
$attach->{'rawheaders'} .= $lines[$l]."\n";
|
|
if ($lines[$l] =~ /^(\S+):\s*(.*)/) {
|
|
push(@headers, [ $1, $2 ]);
|
|
}
|
|
elsif ($lines[$l] =~ /^\s+(.*)/) {
|
|
$headers[$#headers]->[1] .= " ".$1
|
|
unless($#headers < 0);
|
|
}
|
|
$l++;
|
|
}
|
|
$attach->{'raw'} .= $lines[$l]."\n";
|
|
$l++;
|
|
$attach->{'headers'} = \@headers;
|
|
foreach $h (@headers) {
|
|
$attach->{'header'}->{lc($h->[0])} = $h->[1];
|
|
}
|
|
if ($attach->{'header'}->{'content-type'} =~ /^([^;\s]+)/) {
|
|
$attach->{'type'} = lc($1);
|
|
}
|
|
elsif ($ct !~ /^multipart\/\S+/ && $ct =~ /^([^;\s]+)/) {
|
|
$attach->{'type'} = lc($1);
|
|
}
|
|
else {
|
|
$attach->{'type'} = 'text/plain';
|
|
}
|
|
if ($attach->{'header'}->{'content-disposition'} =~
|
|
/filename\s*=\s*"([^"]+)"/i) {
|
|
$attach->{'filename'} = $1;
|
|
}
|
|
elsif ($attach->{'header'}->{'content-disposition'} =~
|
|
/filename\s*=\s*([^;\s]+)/i) {
|
|
$attach->{'filename'} = $1;
|
|
}
|
|
elsif ($attach->{'header'}->{'content-type'} =~
|
|
/name\s*=\s*"([^"]+)"/i) {
|
|
$attach->{'filename'} = $1;
|
|
}
|
|
elsif ($attach->{'header'}->{'content-type'} =~
|
|
/name\s*=\s*([^;\s]+)/i) {
|
|
$attach->{'filename'} = $1;
|
|
}
|
|
|
|
# read the attachment body
|
|
while($l < $max && $lines[$l] ne $bound && $lines[$l] ne "$bound--") {
|
|
$attach->{'data'} .= $lines[$l]."\n";
|
|
$attach->{'raw'} .= $lines[$l]."\n";
|
|
$l++;
|
|
}
|
|
$attach->{'data'} =~ s/\n\n$/\n/; # Lose trailing blank line
|
|
$attach->{'raw'} =~ s/\n\n$/\n/;
|
|
|
|
# decode if necessary
|
|
if (lc($attach->{'header'}->{'content-transfer-encoding'}) eq
|
|
'base64') {
|
|
# Standard base64 encoded attachment
|
|
$attach->{'data'} = &decode_base64($attach->{'data'});
|
|
}
|
|
elsif (lc($attach->{'header'}->{'content-transfer-encoding'}) eq
|
|
'x-uue') {
|
|
# UUencoded attachment
|
|
$attach->{'data'} = &uudecode($attach->{'data'});
|
|
}
|
|
elsif (lc($attach->{'header'}->{'content-transfer-encoding'}) eq
|
|
'quoted-printable') {
|
|
# Quoted-printable text attachment
|
|
$attach->{'data'} = "ed_decode($attach->{'data'});
|
|
}
|
|
elsif (lc($attach->{'type'}) eq 'application/mac-binhex40' && &has_command("hexbin")) {
|
|
# Macintosh binhex encoded attachment
|
|
local $temp = &transname();
|
|
mkdir($temp, 0700);
|
|
open(HEXBIN, "| (cd $temp ; hexbin -n attach -d 2>/dev/null)");
|
|
print HEXBIN $attach->{'data'};
|
|
close(HEXBIN);
|
|
if (!$?) {
|
|
open(HEXBIN, "<$temp/attach.data");
|
|
local $/ = undef;
|
|
$attach->{'data'} = <HEXBIN>;
|
|
close(HEXBIN);
|
|
local $ct = &guess_mime_type($attach->{'filename'});
|
|
$attach->{'type'} = $ct;
|
|
$attach->{'header'} = { 'content-type' => $ct };
|
|
$attach->{'headers'} = [ [ 'Content-Type', $ct ] ];
|
|
}
|
|
unlink("$temp/attach.data");
|
|
rmdir($temp);
|
|
}
|
|
|
|
$attach->{'idx'} = scalar(@attach);
|
|
$attach->{'parent'} = $_[1] ? $_[1] : $_[0];
|
|
push(@attach, $attach) if (@headers || $attach->{'data'});
|
|
if ($attach->{'type'} =~ /multipart\/(\S+)/i) {
|
|
# This attachment contains more attachments ..
|
|
# expand them.
|
|
local $amail = { 'header' => $attach->{'header'},
|
|
'body' => $attach->{'data'} };
|
|
&parse_mail($amail, $attach, 0, $_[3]);
|
|
$attach->{'attach'} = [ @{$amail->{'attach'}} ];
|
|
map { $_->{'idx'} += scalar(@attach) }
|
|
@{$amail->{'attach'}};
|
|
push(@attach, @{$amail->{'attach'}});
|
|
}
|
|
elsif (lc($attach->{'type'}) eq 'application/ms-tnef') {
|
|
# This attachment is a winmail.dat file, which may
|
|
# contain multiple other attachments!
|
|
local ($tattach, $terror) =
|
|
&decode_tnef_attachment($attach);
|
|
if ($tattach && @{$tattach}) {
|
|
pop(@attach); # lose winmail.dat
|
|
foreach my $ta (@{$tattach}) {
|
|
$ta->{'idx'} = scalar(@attach);
|
|
push(@attach, $ta);
|
|
}
|
|
}
|
|
else {
|
|
$attach->{'error'} = $terror ||
|
|
"failed to decode winmail.dat";
|
|
}
|
|
}
|
|
last if ($l >= $max || $lines[$l] eq "$bound--");
|
|
$l++;
|
|
}
|
|
$_[0]->{'attach'} = \@attach;
|
|
}
|
|
elsif ($_[0]->{'body'} =~ /begin\s+([0-7]+)\s+(.*)/i) {
|
|
# Message contains uuencoded file(s)
|
|
local @lines = split(/\n/, $_[0]->{'body'});
|
|
local ($attach, $rest);
|
|
foreach $l (@lines) {
|
|
if ($l =~ /^begin\s+([0-7]+)\s+(.*)/i) {
|
|
$attach = { 'type' => &guess_mime_type($2),
|
|
'idx' => scalar(@{$_[0]->{'attach'}}),
|
|
'parent' => $_[1],
|
|
'filename' => $2 };
|
|
push(@{$_[0]->{'attach'}}, $attach);
|
|
}
|
|
elsif ($l =~ /^end/ && $attach) {
|
|
$attach = undef;
|
|
}
|
|
elsif ($attach) {
|
|
$attach->{'data'} .= unpack("u", $l);
|
|
}
|
|
else {
|
|
$rest .= $l."\n";
|
|
}
|
|
}
|
|
if ($rest =~ /\S/) {
|
|
# Some leftover text
|
|
push(@{$_[0]->{'attach'}},
|
|
{ 'type' => "text/plain",
|
|
'idx' => scalar(@{$_[0]->{'attach'}}),
|
|
'parent' => $_[1],
|
|
'data' => $rest });
|
|
}
|
|
}
|
|
elsif (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq 'base64') {
|
|
# Signed body section
|
|
$ct =~ s/;.*$//;
|
|
$_[0]->{'attach'} = [ { 'type' => lc($ct),
|
|
'idx' => 0,
|
|
'parent' => $_[1],
|
|
'data' => &decode_base64($_[0]->{'body'}) } ];
|
|
}
|
|
elsif (lc($_[0]->{'header'}->{'content-type'}) eq 'x-sun-attachment') {
|
|
# Sun attachment format, which can contain several sections
|
|
local $sun;
|
|
foreach $sun (split(/----------/, $_[0]->{'body'})) {
|
|
local ($headers, $rest) = split(/\r?\n\r?\n/, $sun, 2);
|
|
local $attach = { 'idx' => scalar(@{$_[0]->{'attach'}}),
|
|
'parent' => $_[1],
|
|
'data' => $rest };
|
|
if ($headers =~ /X-Sun-Data-Name:\s*(\S+)/) {
|
|
$attach->{'filename'} = $1;
|
|
}
|
|
if ($headers =~ /X-Sun-Data-Type:\s*(\S+)/) {
|
|
local $st = $1;
|
|
$attach->{'type'} = $st eq "text" ? "text/plain" :
|
|
$st eq "html" ? "text/html" :
|
|
$st =~ /\// ? $st : "application/octet-stream";
|
|
}
|
|
elsif ($attach->{'filename'}) {
|
|
$attach->{'type'} =
|
|
&guess_mime_type($attach->{'filename'});
|
|
}
|
|
else {
|
|
$attach->{'type'} = "text/plain"; # fallback
|
|
}
|
|
push(@{$_[0]->{'attach'}}, $attach);
|
|
}
|
|
}
|
|
else {
|
|
# One big attachment (probably text)
|
|
local ($type, $body);
|
|
($type = $ct) =~ s/;.*$//;
|
|
$type = 'text/plain' if (!$type);
|
|
if (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq 'base64') {
|
|
$body = &decode_base64($_[0]->{'body'});
|
|
}
|
|
elsif (lc($_[0]->{'header'}->{'content-transfer-encoding'}) eq
|
|
'quoted-printable') {
|
|
$body = "ed_decode($_[0]->{'body'});
|
|
}
|
|
else {
|
|
$body = $_[0]->{'body'};
|
|
}
|
|
if ($body =~ /\S/) {
|
|
$_[0]->{'attach'} = [ { 'type' => lc($type),
|
|
'idx' => 0,
|
|
'parent' => $_[1],
|
|
'data' => $body } ];
|
|
}
|
|
else {
|
|
# Body is completely empty
|
|
$_[0]->{'attach'} = [ ];
|
|
}
|
|
}
|
|
delete($_[0]->{'body'}) if (!$_[2]);
|
|
}
|
|
|
|
# delete_mail(user|file, &mail, ...)
|
|
# Delete mail messages from a user by copying the file and rebuilding the index
|
|
sub delete_mail
|
|
{
|
|
# Validate messages
|
|
local @m = sort { $a->{'line'} <=> $b->{'line'} } @_[1..@_-1];
|
|
foreach my $m (@m) {
|
|
defined($m->{'line'}) && defined($m->{'eline'}) &&
|
|
$m->{'eline'} > $m->{'line'} ||
|
|
&error("Message to delete is invalid, perhaps to due to ".
|
|
"out-of-date index");
|
|
}
|
|
|
|
local $i = 0;
|
|
local $f = &user_mail_file($_[0]);
|
|
local $ifile = &user_index_file($_[0]);
|
|
local $lnum = 0;
|
|
local (%dline, @fline);
|
|
local ($dpos = 0, $dlnum = 0);
|
|
local (@index, %index);
|
|
&build_dbm_index($_[0], \%index);
|
|
|
|
local $tmpf = $< == 0 ? "$f.del" :
|
|
$_[0] =~ /^\/.*\/([^\/]+)$/ ?
|
|
"$user_module_config_directory/$1.del" :
|
|
"$user_module_config_directory/$_[0].del";
|
|
if (-l $f) {
|
|
$f = &resolve_links($f);
|
|
}
|
|
&open_as_mail_user(SOURCE, $f) || &error("Failed to open $f : $!");
|
|
&create_as_mail_user(DEST, ">$tmpf") ||
|
|
&error("Failed to open temp file $tmpf : $!");
|
|
while(<SOURCE>) {
|
|
if ($i >= @m || $lnum < $m[$i]->{'line'}) {
|
|
# Within a range that we want to preserve
|
|
$dpos += length($_);
|
|
$dlnum++;
|
|
local $w = (print DEST $_);
|
|
if (!$w) {
|
|
local $e = "$!";
|
|
close(DEST);
|
|
close(SOURCE);
|
|
unlink($tmpf);
|
|
&error("Write to $tmpf failed : $e");
|
|
}
|
|
}
|
|
elsif (!$fline[$i]) {
|
|
# Start line of a message to delete
|
|
if (!/^From\s/) {
|
|
# Not actually a message! Fail now
|
|
close(DEST);
|
|
close(SOURCE);
|
|
unlink($tmpf);
|
|
&error("Index on $f is corrupt - did not find expected message start at line $lnum");
|
|
}
|
|
$fline[$i] = 1;
|
|
}
|
|
elsif ($lnum == $m[$i]->{'eline'}) {
|
|
# End line of the current message to delete
|
|
$dline{$m[$i]->{'line'}}++;
|
|
$i++;
|
|
}
|
|
$lnum++;
|
|
}
|
|
close(SOURCE);
|
|
close(DEST) || &error("Write to $tmpf failed : $?");
|
|
local @st = stat($f);
|
|
|
|
# Force a total index re-build (XXX lazy!)
|
|
$index{'mailcount'} = $in{'lastchange'} = 0;
|
|
dbmclose(%index);
|
|
|
|
if ($< == 0) {
|
|
# Replace the mail file with the copy
|
|
unlink($f);
|
|
rename($tmpf, $f);
|
|
if (!&should_switch_to_mail_user()) {
|
|
# Since write was done as root, set back permissions on the
|
|
# mail file to match the original
|
|
chown($st[4], $st[5], $f);
|
|
chmod($st[2], $f);
|
|
}
|
|
else {
|
|
&chmod_as_mail_user($st[2], $f);
|
|
}
|
|
}
|
|
else {
|
|
system("cat ".quotemeta($tmpf)." > ".quotemeta($f).
|
|
" && rm -f ".quotemeta($tmpf));
|
|
}
|
|
}
|
|
|
|
# modify_mail(user|file, old, new, textonly)
|
|
# Modify one email message in a mailbox by copying the file and rebuilding
|
|
# the index.
|
|
sub modify_mail
|
|
{
|
|
local $f = &user_mail_file($_[0]);
|
|
local $ifile = &user_index_file($_[0]);
|
|
local $lnum = 0;
|
|
local ($sizediff, $linesdiff);
|
|
local %index;
|
|
&build_dbm_index($_[0], \%index);
|
|
|
|
# Replace the email that gets modified
|
|
local $tmpf = $< == 0 ? "$f.del" :
|
|
$_[0] =~ /^\/.*\/([^\/]+)$/ ?
|
|
"$user_module_config_directory/$1.del" :
|
|
"$user_module_config_directory/$_[0].del";
|
|
if (-l $f) {
|
|
$f = &resolve_links($f);
|
|
}
|
|
&open_as_mail_user(SOURCE, $f) || &error("Failed to open $f : $!");
|
|
&create_as_mail_user(DEST, ">$tmpf") ||
|
|
&error("Failed to open temp file $tmpf : $!");
|
|
while(<SOURCE>) {
|
|
if ($lnum < $_[1]->{'line'} || $lnum > $_[1]->{'eline'}) {
|
|
# before or after the message to change
|
|
local $w = (print DEST $_);
|
|
if (!$w) {
|
|
local $e = "$?";
|
|
close(DEST);
|
|
close(SOURCE);
|
|
unlink($tmpf);
|
|
&error("Write to $tmpf failed : $e");
|
|
}
|
|
}
|
|
elsif ($lnum == $_[1]->{'line'}) {
|
|
# found start of message to change .. put in the new one
|
|
close(DEST);
|
|
local @ost = stat($tmpf);
|
|
local $nlines = &send_mail($_[2], $tmpf, $_[3], 1);
|
|
local @nst = stat($tmpf);
|
|
local $newsize = $nst[7] - $ost[7];
|
|
$sizediff = $newsize - $_[1]->{'size'};
|
|
$linesdiff = $nlines - ($_[1]->{'eline'} - $_[1]->{'line'} + 1);
|
|
&open_as_mail_user(DEST, ">>$tmpf");
|
|
}
|
|
$lnum++;
|
|
}
|
|
close(SOURCE);
|
|
close(DEST) || &error("Write failed : $!");
|
|
|
|
# Now update the index and delete the temp file
|
|
for($i=0; $i<$index{'mailcount'}; $i++) {
|
|
local @idx = split(/\0/, $index{$i});
|
|
if ($idx[1] > $_[1]->{'line'}) {
|
|
$idx[0] += $sizediff;
|
|
$idx[1] += $linesdiff;
|
|
$index{$i} = join("\0", @idx);
|
|
}
|
|
}
|
|
$index{'lastchange'} = time();
|
|
local @st = stat($f);
|
|
if ($< == 0) {
|
|
unlink($f);
|
|
rename($tmpf, $f);
|
|
if (!&should_switch_to_mail_user()) {
|
|
# Since write was done as root, set back permissions on the
|
|
# mail file to match the original
|
|
chown($st[4], $st[5], $f);
|
|
chmod($st[2], $f);
|
|
}
|
|
else {
|
|
&chmod_as_mail_user($st[2], $f);
|
|
}
|
|
}
|
|
else {
|
|
system("cat $tmpf >$f && rm -f $tmpf");
|
|
}
|
|
chown($st[4], $st[5], $f);
|
|
chmod($st[2], $f);
|
|
}
|
|
|
|
# send_mail(&mail, [file], [textonly], [nocr], [smtp-server],
|
|
# [smtp-user], [smtp-pass], [smtp-auth-mode],
|
|
# [¬ify-flags], [port], [use-ssl])
|
|
# Send out some email message or append it to a file.
|
|
# Returns the number of lines written.
|
|
sub send_mail
|
|
{
|
|
local ($mail, $file, $textonly, $nocr, $sm, $user, $pass, $auth,
|
|
$flags, $port, $ssl) = @_;
|
|
return 0 if (&is_readonly_mode());
|
|
local $lnum = 0;
|
|
$sm ||= $config{'send_mode'};
|
|
local $eol = $nocr || !$sm ? "\n" : "\r\n";
|
|
$ssl = $config{'smtp_ssl'} if ($ssl eq '');
|
|
local $defport = $ssl == 1 ? 465 : 25;
|
|
$port ||= $config{'smtp_port'} || $defport;
|
|
my %header;
|
|
foreach my $head (@{$mail->{'headers'}}) {
|
|
$header{lc($head->[0])} = $head->[1];
|
|
}
|
|
|
|
# Add the date header, always in english
|
|
&clear_time_locale();
|
|
local @tm = localtime(time());
|
|
push(@{$mail->{'headers'}},
|
|
[ 'Date', strftime("%a, %d %b %Y %H:%M:%S %z (%Z)", @tm) ])
|
|
if (!$header{'date'});
|
|
&reset_time_locale();
|
|
|
|
# Build list of destination email addresses
|
|
my @dests;
|
|
foreach my $f ("to", "cc", "bcc") {
|
|
if ($header{$f}) {
|
|
push(@dests, &address_parts($header{$f}));
|
|
}
|
|
}
|
|
my $qdests = join(" ", map { quotemeta($_) } @dests);
|
|
|
|
local @from = &address_parts($header{'from'});
|
|
local $fromaddr;
|
|
if (@from && $from[0] =~ /\S/) {
|
|
$fromaddr = $from[0];
|
|
}
|
|
else {
|
|
local @uinfo = getpwuid($<);
|
|
$fromaddr = $uinfo[0] || "nobody";
|
|
$fromaddr .= '@'.&get_system_hostname();
|
|
}
|
|
local $qfromaddr = quotemeta($fromaddr);
|
|
local $esmtp = $flags ? 1 : 0;
|
|
my $h = { 'fh' => 'mailboxes::MAIL' };
|
|
if ($file) {
|
|
# Just append the email to a file using mbox format
|
|
&open_as_mail_user($h->{'fh'}, ">>$file") ||
|
|
&error("Write failed : $!");
|
|
$lnum++;
|
|
&write_http_connection($h,
|
|
$mail->{'fromline'} ? $mail->{'fromline'}.$eol :
|
|
&make_from_line($fromaddr).$eol);
|
|
}
|
|
elsif ($sm) {
|
|
# Connect to SMTP server
|
|
&open_socket($sm, $port, $h->{'fh'});
|
|
|
|
if ($ssl == 1) {
|
|
# Start using SSL mode right away
|
|
&switch_smtp_to_ssl($h);
|
|
}
|
|
|
|
&smtp_command($h, undef, 0);
|
|
|
|
# Send SMTP HELO
|
|
my $helo = $config{'helo_name'} || &get_system_hostname();
|
|
my $helocmd = $esmtp ? "ehlo $helo\r\n" : "helo $helo\r\n";
|
|
&smtp_command($h, $helocmd, 0);
|
|
|
|
if ($ssl == 2) {
|
|
# Switch to SSL with STARTTLS, if possible
|
|
my $rv = &smtp_command($h, "starttls\r\n", 1);
|
|
if ($rv =~ /^2\d+/) {
|
|
&switch_smtp_to_ssl($h);
|
|
&smtp_command($h, $helocmd, 0);
|
|
}
|
|
else {
|
|
$ssl = 0;
|
|
}
|
|
}
|
|
|
|
# Get username and password from parameters, or from module config
|
|
$user ||= $userconfig{'smtp_user'} || $config{'smtp_user'};
|
|
$pass ||= $userconfig{'smtp_pass'} || $config{'smtp_pass'};
|
|
$auth ||= $userconfig{'smtp_auth'} ||
|
|
$config{'smtp_auth'} || "Cram-MD5";
|
|
if ($user) {
|
|
# Send authentication commands
|
|
eval "use Authen::SASL";
|
|
if ($@) {
|
|
&error("Perl module <tt>Authen::SASL</tt> is needed for SMTP authentication");
|
|
}
|
|
my $sasl = Authen::SASL->new('mechanism' => uc($auth),
|
|
'callback' => {
|
|
'auth' => $user,
|
|
'user' => $user,
|
|
'pass' => $pass } );
|
|
&error("Failed to create Authen::SASL object") if (!$sasl);
|
|
local $conn = $sasl->client_new("smtp", &get_system_hostname());
|
|
local $arv = &smtp_command($h, "AUTH ".uc($auth)."\r\n", 1);
|
|
if ($arv =~ /^(334)(\-\S+)?\s+(.*)/) {
|
|
# Server says to go ahead
|
|
$extra = $3;
|
|
local $initial = $conn->client_start();
|
|
local $auth_ok;
|
|
if ($initial) {
|
|
local $enc = &encode_base64($initial);
|
|
$enc =~ s/\r|\n//g;
|
|
$arv = &smtp_command($h, "$enc\r\n", 1);
|
|
if ($arv =~ /^(\d+)(\-\S+)?\s+(.*)/) {
|
|
if ($1 == 235) {
|
|
$auth_ok = 1;
|
|
}
|
|
else {
|
|
&error("Unknown SMTP authentication response : $arv");
|
|
}
|
|
}
|
|
$extra = $3;
|
|
}
|
|
while(!$auth_ok) {
|
|
local $message = &decode_base64($extra);
|
|
local $return = $conn->client_step($message);
|
|
local $enc = &encode_base64($return);
|
|
$enc =~ s/\r|\n//g;
|
|
$arv = &smtp_command($h, "$enc\r\n", 1);
|
|
if ($arv =~ /^(\d+)(\-\S+)?\s+(.*)/) {
|
|
if ($1 == 235) {
|
|
$auth_ok = 1;
|
|
}
|
|
elsif ($1 == 535) {
|
|
&error("SMTP authentication failed : $arv");
|
|
}
|
|
$extra = $3;
|
|
}
|
|
else {
|
|
&error("Unknown SMTP authentication response : $arv");
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
&smtp_command($h, "mail from: <$fromaddr>\r\n", 0);
|
|
local $notify = $flags ? " NOTIFY=".join(",", @$flags) : "";
|
|
foreach my $u (@dests) {
|
|
&smtp_command($h, "rcpt to: <$u>$notify\r\n", 0);
|
|
}
|
|
&smtp_command($h, "data\r\n", 0);
|
|
}
|
|
elsif (defined(&send_mail_program)) {
|
|
# Use specified mail injector
|
|
local $cmd = &send_mail_program($fromaddr, \@dests);
|
|
$cmd || &error("No mail program was found on your system!");
|
|
open($h->{'fh'}, "| $cmd >/dev/null 2>&1");
|
|
}
|
|
elsif ($config{'qmail_dir'}) {
|
|
# Start qmail-inject
|
|
open($h->{'fh'}, "| $config{'qmail_dir'}/bin/qmail-inject");
|
|
}
|
|
elsif ($config{'postfix_control_command'}) {
|
|
# Start postfix's sendmail wrapper
|
|
local $cmd = -x "/usr/lib/sendmail" ? "/usr/lib/sendmail" :
|
|
&has_command("sendmail");
|
|
$cmd || &error($text{'send_ewrapper'});
|
|
open($h->{'fh'}, "| $cmd -f$qfromaddr $qdests >/dev/null 2>&1");
|
|
}
|
|
else {
|
|
# Start sendmail
|
|
&has_command($config{'sendmail_path'}) ||
|
|
&error(&text('send_epath', "<tt>$config{'sendmail_path'}</tt>"));
|
|
open($h->{'fh'}, "| $config{'sendmail_path'} -f$qfromaddr $qdests >/dev/null 2>&1");
|
|
}
|
|
|
|
local $ctype = "multipart/mixed";
|
|
local $msg_id;
|
|
foreach $head (@{$mail->{'headers'}}) {
|
|
if (defined($mail->{'body'}) || $textonly) {
|
|
&write_http_connection($h, $head->[0],": ",$head->[1],$eol);
|
|
$lnum++;
|
|
}
|
|
else {
|
|
if ($head->[0] !~ /^(MIME-Version|Content-Type)$/i) {
|
|
&write_http_connection($h, $head->[0],": ",$head->[1],$eol);
|
|
$lnum++;
|
|
}
|
|
elsif (lc($head->[0]) eq 'content-type') {
|
|
$ctype = $head->[1];
|
|
}
|
|
}
|
|
if (lc($head->[0]) eq 'message-id') {
|
|
$msg_id++;
|
|
}
|
|
}
|
|
if (!$msg_id) {
|
|
# Add a message-id header if missing
|
|
$main::mailboxes_message_id_count++;
|
|
&write_http_connection($h, "Message-Id: <",time().".".$$.".".
|
|
$main::mailboxes_message_id_count."\@".
|
|
&get_system_hostname(),">",$eol);
|
|
}
|
|
|
|
# Work out first attachment content type
|
|
local ($ftype, $fenc);
|
|
if (@{$mail->{'attach'}} >= 1) {
|
|
local $first = $mail->{'attach'}->[0];
|
|
$ftype = "text/plain";
|
|
foreach my $h (@{$first->{'headers'}}) {
|
|
if (lc($h->[0]) eq "content-type") {
|
|
$ftype = $h->[1];
|
|
}
|
|
if (lc($h->[0]) eq "content-transfer-encoding") {
|
|
$fenc = $h->[1];
|
|
}
|
|
}
|
|
}
|
|
|
|
if (defined($mail->{'body'})) {
|
|
# Use original mail body
|
|
&write_http_connection($h, $eol);
|
|
$lnum++;
|
|
$mail->{'body'} =~ s/\r//g;
|
|
$mail->{'body'} =~ s/\n\.\n/\n\. \n/g;
|
|
$mail->{'body'} =~ s/\n/$eol/g;
|
|
$mail->{'body'} .= $eol if ($mail->{'body'} !~ /\n$/);
|
|
&write_http_connection($h, $mail->{'body'}) || &error("Write failed : $!");
|
|
$lnum += ($mail->{'body'} =~ tr/\n/\n/);
|
|
}
|
|
elsif (!@{$mail->{'attach'}}) {
|
|
# No content, so just send empty email
|
|
&write_http_connection($h, "Content-Type: text/plain",$eol);
|
|
&write_http_connection($h, $eol);
|
|
$lnum += 2;
|
|
}
|
|
elsif (!$textonly || $ftype !~ /text\/plain/i ||
|
|
$fenc =~ /quoted-printable|base64/) {
|
|
# Sending MIME-encoded email
|
|
if ($ctype !~ /multipart\/report/i) {
|
|
$ctype =~ s/;.*$//;
|
|
}
|
|
&write_http_connection($h, "MIME-Version: 1.0",$eol);
|
|
local $bound = "bound".time();
|
|
&write_http_connection($h, "Content-Type: $ctype; boundary=\"$bound\"",$eol);
|
|
&write_http_connection($h, $eol);
|
|
$lnum += 3;
|
|
|
|
# Send attachments
|
|
&write_http_connection($h, "This is a multi-part message in MIME format.",$eol);
|
|
$lnum++;
|
|
foreach $a (@{$mail->{'attach'}}) {
|
|
&write_http_connection($h, $eol);
|
|
&write_http_connection($h, "--",$bound,$eol);
|
|
$lnum += 2;
|
|
local $enc;
|
|
foreach $head (@{$a->{'headers'}}) {
|
|
&write_http_connection($h, $head->[0],": ",$head->[1],$eol);
|
|
$enc = $head->[1]
|
|
if (lc($head->[0]) eq 'content-transfer-encoding');
|
|
$lnum++;
|
|
}
|
|
&write_http_connection($h, $eol);
|
|
$lnum++;
|
|
if (lc($enc) eq 'base64') {
|
|
local $enc = &encode_base64($a->{'data'});
|
|
$enc =~ s/\r//g;
|
|
$enc =~ s/\n/$eol/g;
|
|
&write_http_connection($h, $enc);
|
|
$lnum += ($enc =~ tr/\n/\n/);
|
|
}
|
|
else {
|
|
$a->{'data'} =~ s/\r//g;
|
|
$a->{'data'} =~ s/\n\.\n/\n\. \n/g;
|
|
$a->{'data'} =~ s/\n/$eol/g;
|
|
&write_http_connection($h, $a->{'data'});
|
|
$lnum += ($a->{'data'} =~ tr/\n/\n/);
|
|
if ($a->{'data'} !~ /\n$/) {
|
|
&write_http_connection($h, $eol);
|
|
$lnum++;
|
|
}
|
|
}
|
|
}
|
|
&write_http_connection($h, $eol);
|
|
&write_http_connection($h, "--",$bound,"--",$eol) ||
|
|
&error("Write failed : $!");
|
|
&write_http_connection($h, $eol);
|
|
$lnum += 3;
|
|
}
|
|
else {
|
|
# Sending text-only mail from first attachment
|
|
local $a = $mail->{'attach'}->[0];
|
|
&write_http_connection($h, $eol);
|
|
$lnum++;
|
|
$a->{'data'} =~ s/\r//g;
|
|
$a->{'data'} =~ s/\n/$eol/g;
|
|
&write_http_connection($h, $a->{'data'}) || &error("Write failed : $!");
|
|
$lnum += ($a->{'data'} =~ tr/\n/\n/);
|
|
if ($a->{'data'} !~ /\n$/) {
|
|
&write_http_connection($h, $eol);
|
|
$lnum++;
|
|
}
|
|
}
|
|
if ($sm && !$file) {
|
|
&smtp_command($h, ".$eol", 0);
|
|
&smtp_command($h, "quit$eol", 0);
|
|
}
|
|
if (!&close_http_connection($h)) {
|
|
# Only bother to report an error on close if writing to a file
|
|
if ($file) {
|
|
&error("Write failed : $!");
|
|
}
|
|
}
|
|
return $lnum;
|
|
}
|
|
|
|
# switch_smtp_to_ssl(&handle)
|
|
# Switch an SMTP connection handle to SSL mode
|
|
sub switch_smtp_to_ssl
|
|
{
|
|
my ($h) = @_;
|
|
eval "use Net::SSLeay";
|
|
$@ && &error($text{'link_essl'});
|
|
eval "Net::SSLeay::SSLeay_add_ssl_algorithms()";
|
|
eval "Net::SSLeay::load_error_strings()";
|
|
$h->{'ssl_ctx'} = Net::SSLeay::CTX_new() ||
|
|
&error("Failed to create SSL context");
|
|
$h->{'ssl_con'} = Net::SSLeay::new($h->{'ssl_ctx'}) ||
|
|
&error("Failed to create SSL connection");
|
|
Net::SSLeay::set_fd($h->{'ssl_con'}, fileno($h->{'fh'}));
|
|
Net::SSLeay::connect($h->{'ssl_con'}) ||
|
|
&error("SSL connect() failed");
|
|
}
|
|
|
|
# unparse_mail(&attachments, eol, boundary)
|
|
# Convert an array of attachments into MIME format, and return them as an
|
|
# array of lines.
|
|
sub unparse_mail
|
|
{
|
|
local ($attach, $eol, $bound) = @_;
|
|
local @rv;
|
|
foreach my $a (@$attach) {
|
|
push(@rv, $eol);
|
|
push(@rv, "--".$bound.$eol);
|
|
local $enc;
|
|
foreach my $h (@{$a->{'headers'}}) {
|
|
push(@rv, $h->[0].": ".$h->[1].$eol);
|
|
$enc = $h->[1]
|
|
if (lc($h->[0]) eq 'content-transfer-encoding');
|
|
}
|
|
push(@rv, $eol);
|
|
if (lc($enc) eq 'base64') {
|
|
local $enc = &encode_base64($a->{'data'});
|
|
$enc =~ s/\r//g;
|
|
foreach my $l (split(/\n/, $enc)) {
|
|
push(@rv, $l.$eol);
|
|
}
|
|
}
|
|
else {
|
|
$a->{'data'} =~ s/\r//g;
|
|
$a->{'data'} =~ s/\n\.\n/\n\. \n/g;
|
|
foreach my $l (split(/\n/, $a->{'data'})) {
|
|
push(@rv, $l.$eol);
|
|
}
|
|
}
|
|
}
|
|
push(@rv, $eol);
|
|
push(@rv, "--".$bound."--".$eol);
|
|
push(@rv, $eol);
|
|
return @rv;
|
|
}
|
|
|
|
# mail_size(&mail, [textonly])
|
|
# Returns the size of an email message in bytes
|
|
sub mail_size
|
|
{
|
|
local ($mail, $textonly) = @_;
|
|
local $temp = &transname();
|
|
&send_mail($mail, $temp, $textonly);
|
|
local @st = stat($temp);
|
|
unlink($temp);
|
|
return $st[7];
|
|
}
|
|
|
|
# can_read_mail(user)
|
|
sub can_read_mail
|
|
{
|
|
return 1 if ($_[0] && $access{'sent'} eq $_[0]);
|
|
local @u = getpwnam($_[0]);
|
|
return 0 if (!@u);
|
|
return 0 if ($_[0] =~ /\.\./);
|
|
return 0 if ($access{'mmode'} == 0);
|
|
return 1 if ($access{'mmode'} == 1);
|
|
local $u;
|
|
if ($access{'mmode'} == 2) {
|
|
foreach $u (split(/\s+/, $access{'musers'})) {
|
|
return 1 if ($u eq $_[0]);
|
|
}
|
|
return 0;
|
|
}
|
|
elsif ($access{'mmode'} == 4) {
|
|
return 1 if ($_[0] eq $remote_user);
|
|
}
|
|
elsif ($access{'mmode'} == 5) {
|
|
return $u[3] eq $access{'musers'};
|
|
}
|
|
elsif ($access{'mmode'} == 3) {
|
|
foreach $u (split(/\s+/, $access{'musers'})) {
|
|
return 0 if ($u eq $_[0]);
|
|
}
|
|
return 1;
|
|
}
|
|
elsif ($access{'mmode'} == 6) {
|
|
return ($_[0] =~ /^$access{'musers'}$/);
|
|
}
|
|
elsif ($access{'mmode'} == 7) {
|
|
return (!$access{'musers'} || $u[2] >= $access{'musers'}) &&
|
|
(!$access{'musers2'} || $u[2] <= $access{'musers2'});
|
|
}
|
|
return 0; # can't happen!
|
|
}
|
|
|
|
# from_hostname()
|
|
sub from_hostname
|
|
{
|
|
local ($d, $masq);
|
|
local $conf = &get_sendmailcf();
|
|
foreach $d (&find_type("D", $conf)) {
|
|
if ($d->{'value'} =~ /^M\s*(\S*)/) { $masq = $1; }
|
|
}
|
|
return $masq ? $masq : &get_system_hostname();
|
|
}
|
|
|
|
# mail_from_queue(qfile, [dfile|"auto"])
|
|
# Reads a message from the Sendmail mail queue
|
|
sub mail_from_queue
|
|
{
|
|
local $mail = { 'file' => $_[0] };
|
|
$mail->{'quar'} = $_[0] =~ /\/hf/;
|
|
$mail->{'lost'} = $_[0] =~ /\/Qf/;
|
|
if ($_[1] eq "auto") {
|
|
$mail->{'dfile'} = $_[0];
|
|
$mail->{'dfile'} =~ s/\/(qf|hf|Qf)/\/df/;
|
|
}
|
|
elsif ($_[1]) {
|
|
$mail->{'dfile'} = $_[1];
|
|
}
|
|
$mail->{'lfile'} = $_[0];
|
|
$mail->{'lfile'} =~ s/\/(qf|hf|Qf)/\/xf/;
|
|
local $_;
|
|
local @headers;
|
|
open(QF, "<", $_[0]) || return undef;
|
|
while(<QF>) {
|
|
s/\r|\n//g;
|
|
if (/^M(.*)/) {
|
|
$mail->{'status'} = $1;
|
|
}
|
|
elsif (/^H\?[^\?]*\?(\S+):\s+(.*)/ || /^H(\S+):\s+(.*)/) {
|
|
push(@headers, [ $1, $2 ]);
|
|
$mail->{'rawheaders'} .= "$1: $2\n";
|
|
}
|
|
elsif (/^\s+(.*)/) {
|
|
$headers[$#headers]->[1] .= $1 unless($#headers < 0);
|
|
$mail->{'rawheaders'} .= $_."\n";
|
|
}
|
|
}
|
|
close(QF);
|
|
$mail->{'headers'} = \@headers;
|
|
foreach $h (@headers) {
|
|
$mail->{'header'}->{lc($h->[0])} = $h->[1];
|
|
}
|
|
|
|
if ($mail->{'dfile'}) {
|
|
# Read the mail body
|
|
open(DF, "<", $mail->{'dfile'});
|
|
while(<DF>) {
|
|
$mail->{'body'} .= $_;
|
|
}
|
|
close(DF);
|
|
}
|
|
local $datafile = $mail->{'dfile'};
|
|
if (!$datafile) {
|
|
($datafile = $mail->{'file'}) =~ s/\/(qf|hf|Qf)/\/df/;
|
|
}
|
|
local @st0 = stat($mail->{'file'});
|
|
local @st1 = stat($datafile);
|
|
$mail->{'size'} = $st0[7] + $st1[7];
|
|
return $mail;
|
|
}
|
|
|
|
# wrap_lines(text, width)
|
|
# Given a multi-line string, return an array of lines wrapped to
|
|
# the given width
|
|
sub wrap_lines
|
|
{
|
|
local @rv;
|
|
local $w = $_[1];
|
|
foreach $rest (split(/\n/, $_[0])) {
|
|
if ($rest =~ /\S/) {
|
|
while($rest =~ /^(.{1,$w}\S*)\s*([\0-\377]*)$/) {
|
|
push(@rv, $1);
|
|
$rest = $2;
|
|
}
|
|
}
|
|
else {
|
|
# Empty line .. keep as it is
|
|
push(@rv, $rest);
|
|
}
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
# smtp_command(&handle, command, no-error)
|
|
# Send a single SMTP command to some file handle, and read back the response
|
|
sub smtp_command
|
|
{
|
|
my ($h, $c, $noerr) = @_;
|
|
if ($c) {
|
|
&write_http_connection($h, $c);
|
|
}
|
|
my $r = &read_http_connection($h);
|
|
if ($r !~ /^[23]\d+/ && !$noerr) {
|
|
$c =~ s/\r|\n//g;
|
|
&error(&text('send_esmtp', "<tt>".&html_escape($c)."</tt>",
|
|
"<tt>".&html_escape($r)."</tt>"));
|
|
}
|
|
$r =~ s/\r|\n//g;
|
|
if ($r =~ /^(\d+)\-/) {
|
|
# multi-line ESMTP response!
|
|
while(1) {
|
|
my $nr = &read_http_connection($h);
|
|
$nr =~ s/\r|\n//g;
|
|
if ($nr =~ /^(\d+)\-(.*)/) {
|
|
$r .= "\n".$2;
|
|
}
|
|
elsif ($nr =~ /^(\d+)\s+(.*)/) {
|
|
$r .= "\n".$2;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
return $r;
|
|
}
|
|
|
|
# address_parts(string)
|
|
# Returns the email addresses in a string
|
|
sub address_parts
|
|
{
|
|
local @rv = map { $_->[0] } &split_addresses($_[0]);
|
|
return wantarray ? @rv : $rv[0];
|
|
}
|
|
|
|
# link_urls(text, separate)
|
|
# Converts URLs into HTML links
|
|
sub link_urls
|
|
{
|
|
local $r = $_[0];
|
|
local $tar = $_[1] ? "target=_blank" : "";
|
|
$r =~ s/((http|ftp|https|mailto):[^><"'\s]+[^><"'\s\.\)])/<a href="$1" $tar>$1<\/a>/g;
|
|
return $r;
|
|
}
|
|
|
|
# link_urls_and_escape(text, separate)
|
|
# HTML escapes some text, as well as properly linking URLs in it
|
|
sub link_urls_and_escape
|
|
{
|
|
local $l = $_[0];
|
|
local $rv;
|
|
local $tar = $_[1] ? " target=_blank" : "";
|
|
while($l =~ /^(.*?)((http|ftp|https|mailto):[^><"'\s]+[^><"'\s\.\)])(.*)/) {
|
|
local ($before, $url, $after) = ($1, $2, $4);
|
|
$rv .= &eucconv_and_escape($before)."<a href='$url' $tar>".
|
|
&html_escape($url)."</a>";
|
|
$l = $after;
|
|
}
|
|
$rv .= &eucconv_and_escape($l);
|
|
return $rv;
|
|
}
|
|
|
|
# links_urls_new_target(html)
|
|
# Converts any links without targets to open in a new window
|
|
sub links_urls_new_target
|
|
{
|
|
local $l = $_[0];
|
|
local $rv;
|
|
while($l =~ s/^([\0-\377]*?)<\s*a\s+([^>]*href[^>]*)>//i) {
|
|
local ($before, $a) = ($1, $2);
|
|
if ($a !~ /target\s*=/i) {
|
|
$a .= " target=_blank";
|
|
}
|
|
$rv .= $before."<a ".$a.">";
|
|
}
|
|
$rv .= $l;
|
|
return $rv;
|
|
}
|
|
|
|
# uudecode(text)
|
|
sub uudecode
|
|
{
|
|
local @lines = split(/\n/, $_[0]);
|
|
local ($l, $data);
|
|
for($l=0; $lines[$l] !~ /begin\s+([0-7]+)\s/i; $l++) { }
|
|
while($lines[++$l]) {
|
|
$data .= unpack("u", $lines[$l]);
|
|
}
|
|
return $data;
|
|
}
|
|
|
|
# simplify_date(datestring, [format])
|
|
# Given a date from an email header, convert to the user's preferred format and
|
|
# return it as an HTML string
|
|
sub simplify_date
|
|
{
|
|
local ($date, $fmt) = @_;
|
|
local $u = &parse_mail_date($date);
|
|
if ($u) {
|
|
my $locale;
|
|
if ($userconfig{'date_fmt'} eq 'auto' || $config{'date_fmt'} eq 'auto') {
|
|
eval "use DateTime; use DateTime::Locale; use DateTime::TimeZone;";
|
|
if (!$@ && $] > 5.011) {
|
|
$locale++;
|
|
return &make_date($u, undef, $fmt);
|
|
}
|
|
}
|
|
if (!$locale) {
|
|
$fmt ||= $userconfig{'date_fmt'} || $config{'date_fmt'} || "dmy";
|
|
local $strf = $fmt eq "dmy" ? "%d/%m/%Y" :
|
|
$fmt eq "mdy" ? "%m/%d/%Y" :
|
|
"%Y/%m/%d";
|
|
return strftime("$strf %H:%M", localtime($u));
|
|
}
|
|
}
|
|
elsif ($date =~ /^(\S+),\s+0*(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+)/) {
|
|
return &html_escape("$2/$3/$4 $5:$6");
|
|
}
|
|
elsif ($date =~ /^0*(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+)/) {
|
|
return &html_escape("$1/$2/$3 $4:$5");
|
|
}
|
|
return &html_escape($date);
|
|
}
|
|
|
|
# simplify_from(from)
|
|
# Simplifies a From: address for display in the mail list. Only the first
|
|
# address is returned.
|
|
sub simplify_from
|
|
{
|
|
local $rv = &convert_header_for_display($_[0], 0, 1);
|
|
local @sp = &split_addresses($rv);
|
|
if (!@sp) {
|
|
return $text{'mail_nonefrom'};
|
|
}
|
|
else {
|
|
local $first = &html_escape($sp[0]->[1] ? $sp[0]->[1] : $sp[0]->[2]);
|
|
if (length($first) > 80) {
|
|
return substr($first, 0, 80)." ..";
|
|
}
|
|
else {
|
|
return $first.(@sp > 1 ? " , ..." : "");
|
|
}
|
|
}
|
|
}
|
|
|
|
# convert_header_for_display(string, [max-non-html-length], [no-escape])
|
|
# Given a string from an email header, perform all mime-decoding, charset
|
|
# changes and HTML escaping needed to render it in a browser
|
|
sub convert_header_for_display
|
|
{
|
|
local ($str, $max, $noescape) = @_;
|
|
local ($mw, $cs) = &decode_mimewords($str);
|
|
if (&get_charset() eq 'UTF-8' && &can_convert_to_utf8($mw, $cs)) {
|
|
$mw = &convert_to_utf8($mw, $cs);
|
|
}
|
|
local $rv = &eucconv($mw);
|
|
$rv = substr($rv, 0, $max)." .." if ($max && length($rv) > $max);
|
|
return $noescape ? $rv : &html_escape($rv);
|
|
}
|
|
|
|
# simplify_subject(subject)
|
|
# Simplifies and truncates a subject header for display in the mail list
|
|
sub simplify_subject
|
|
{
|
|
return &convert_header_for_display($_[0], int($in{'simplify-subject-length'}) || 100);
|
|
}
|
|
|
|
# quoted_decode(text)
|
|
# Converts quoted-printable format to the original
|
|
sub quoted_decode
|
|
{
|
|
local $t = $_[0];
|
|
$t =~ s/[ \t]+?(\r?\n)/$1/g;
|
|
$t =~ s/=\r?\n//g;
|
|
$t =~ s/(^|[^\r])\n\Z/$1\r\n/;
|
|
$t =~ s/=([a-fA-F0-9]{2})/pack("c",hex($1))/ge;
|
|
return $t;
|
|
}
|
|
|
|
# quoted_encode(text)
|
|
# Encodes text to quoted-printable format
|
|
sub quoted_encode
|
|
{
|
|
local $t = $_[0];
|
|
$t =~ s/([=\177-\377])/sprintf("=%2.2X",ord($1))/ge;
|
|
return $t;
|
|
}
|
|
|
|
# decode_mimewords(string)
|
|
# Converts a string in MIME words format like
|
|
# =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= to actual 8-bit characters
|
|
sub decode_mimewords {
|
|
my $encstr = shift;
|
|
my %params = @_;
|
|
my @tokens;
|
|
$@ = ''; ### error-return
|
|
|
|
### Collapse boundaries between adjacent encoded words:
|
|
$encstr =~ s{(\?\=)\r?\n?[ \t](\=\?)}{$1$2}gs;
|
|
pos($encstr) = 0;
|
|
### print STDOUT "ENC = [", $encstr, "]\n";
|
|
|
|
### Decode:
|
|
my ($charset, $encoding, $enc, $dec);
|
|
while (1) {
|
|
last if (pos($encstr) >= length($encstr));
|
|
my $pos = pos($encstr); ### save it
|
|
|
|
### Case 1: are we looking at "=?..?..?="?
|
|
if ($encstr =~ m{\G # from where we left off..
|
|
=\?([^?]*) # "=?" + charset +
|
|
\?([bq]) # "?" + encoding +
|
|
\?([^?]+) # "?" + data maybe with spcs +
|
|
\?= # "?="
|
|
}xgi) {
|
|
($charset, $encoding, $enc) = ($1, lc($2), $3);
|
|
$dec = (($encoding eq 'q') ? _decode_Q($enc) : _decode_B($enc));
|
|
push @tokens, [$dec, $charset];
|
|
next;
|
|
}
|
|
|
|
### Case 2: are we looking at a bad "=?..." prefix?
|
|
### We need this to detect problems for case 3, which stops at "=?":
|
|
pos($encstr) = $pos; # reset the pointer.
|
|
if ($encstr =~ m{\G=\?}xg) {
|
|
$@ .= qq|unterminated "=?..?..?=" in "$encstr" (pos $pos)\n|;
|
|
push @tokens, ['=?'];
|
|
next;
|
|
}
|
|
|
|
### Case 3: are we looking at ordinary text?
|
|
pos($encstr) = $pos; # reset the pointer.
|
|
if ($encstr =~ m{\G # from where we left off...
|
|
([\x00-\xFF]*? # shortest possible string,
|
|
\n*) # followed by 0 or more NLs,
|
|
(?=(\Z|=\?)) # terminated by "=?" or EOS
|
|
}xg) {
|
|
length($1) or die "MIME::Words: internal logic err: empty token\n";
|
|
push @tokens, [$1];
|
|
next;
|
|
}
|
|
|
|
### Case 4: bug!
|
|
die "MIME::Words: unexpected case:\n($encstr) pos $pos\n\t".
|
|
"Please alert developer.\n";
|
|
}
|
|
if (wantarray) {
|
|
return (join('',map {$_->[0]} @tokens), $charset);
|
|
} else {
|
|
return join('',map {$_->[0]} @tokens);
|
|
}
|
|
}
|
|
|
|
# _decode_Q STRING
|
|
# Private: used by _decode_header() to decode "Q" encoding, which is
|
|
# almost, but not exactly, quoted-printable. :-P
|
|
sub _decode_Q {
|
|
my $str = shift;
|
|
$str =~ s/_/\x20/g; # RFC-1522, Q rule 2
|
|
$str =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge; # RFC-1522, Q rule 1
|
|
$str;
|
|
}
|
|
|
|
# _decode_B STRING
|
|
# Private: used by _decode_header() to decode "B" encoding.
|
|
sub _decode_B {
|
|
my $str = shift;
|
|
&decode_base64($str);
|
|
}
|
|
|
|
# encode_mimewords(string, %params)
|
|
# Converts a word with 8-bit characters to MIME words format
|
|
sub encode_mimewords
|
|
{
|
|
my ($rawstr, %params) = @_;
|
|
my $charset = 'UTF-8';
|
|
my $defenc = 'q';
|
|
my $encoding = lc($params{Encoding} || $defenc);
|
|
my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF";
|
|
|
|
if ($rawstr =~ /^[\x20-\x7E]*$/) {
|
|
# No encoding needed
|
|
return $rawstr;
|
|
}
|
|
|
|
### Encode any "words" with unsafe characters.
|
|
### We limit such words to 18 characters, to guarantee that the
|
|
### worst-case encoding give us no more than 54 + ~10 < 75 characters
|
|
my $word;
|
|
$rawstr =~ s{([ a-zA-Z0-9\x7F-\xFF]{1,18})}{ ### get next "word"
|
|
$word = $1;
|
|
$word =~ /(?:[$NONPRINT])|(?:^\s+$)/o ?
|
|
encode_mimeword($word, $encoding, $charset) : # unsafe chars
|
|
$word # OK word
|
|
}xeg;
|
|
$rawstr =~ s/\?==\?/?= =?/g;
|
|
return $rawstr;
|
|
}
|
|
|
|
# can_convert_to_utf8(string, string-charset)
|
|
# Check if the appropriate perl modules are available for UTF-8 conversion
|
|
sub can_convert_to_utf8
|
|
{
|
|
my ($str, $cs) = @_;
|
|
return 0 if ($cs eq "UTF-8");
|
|
return 0 if (!$cs);
|
|
eval "use Encode";
|
|
return 0 if ($@);
|
|
eval "use utf8";
|
|
return 0 if ($@);
|
|
return 1;
|
|
}
|
|
|
|
# convert_to_utf8(string, string-charset)
|
|
# If possible, convert a string to the UTF-8 charset
|
|
sub convert_to_utf8
|
|
{
|
|
my ($str, $cs) = @_;
|
|
&can_convert_to_utf8(@_); # Load modules
|
|
eval {
|
|
$str = Encode::decode($cs, $str);
|
|
utf8::encode($str);
|
|
};
|
|
return $str;
|
|
}
|
|
|
|
# decode_utf7(string)
|
|
# If possible, convert a string like `Gel&APY-schte` to `Gelöschte`
|
|
# It will also convert complex strings like `Gel&APY-schte & Spam`
|
|
sub decode_utf7
|
|
{
|
|
my ($a) = @_;
|
|
eval "use Encode";
|
|
return $a if ($@);
|
|
my $u = find_encoding("UTF-16BE");
|
|
return $a if (!$u);
|
|
my $s = ' ';
|
|
my @a = split($s, $a);
|
|
my @b;
|
|
foreach my $c (@a) {
|
|
my $b;
|
|
# Based on Encode::Unicode::UTF7 by Dan Kogai
|
|
while (pos($c) < length($c)) {
|
|
if ($c =~ /\G([^&]+)/ogc) {
|
|
$b .= "$1";
|
|
}
|
|
elsif ($c =~ /\G\&-/ogc) {
|
|
$b .= "&";
|
|
}
|
|
elsif ($c =~ /\G\&([A-Za-z0-9+,]+)-?/ogsc) {
|
|
my $d = $1;
|
|
$d =~ s/,/\//g;
|
|
my $p = length($d) % 4;
|
|
$d .= "=" x (4 - $p) if ($p);
|
|
$b .= $u->decode(decode_base64($d));
|
|
}
|
|
elsif ($c =~ /\G\&/ogc) {
|
|
$b = $c;
|
|
}
|
|
else {
|
|
return $a;
|
|
}
|
|
}
|
|
push(@b, $b);
|
|
}
|
|
return join($s, @b);
|
|
}
|
|
|
|
# encode_mimewords_address(string, %params)
|
|
# Given a string containing addresses into one with real names mime-words
|
|
# escaped
|
|
sub encode_mimewords_address
|
|
{
|
|
my ($rawstr, %params) = @_;
|
|
my $charset = 'UTF-8';
|
|
my $defenc = 'q';
|
|
my $encoding = lc($params{Encoding} || $defenc);
|
|
if ($rawstr =~ /^[\x20-\x7E]*$/) {
|
|
# No encoding needed
|
|
return $rawstr;
|
|
}
|
|
my @rv;
|
|
foreach my $addr (&split_addresses($rawstr)) {
|
|
my ($email, $name, $orig) = @$addr;
|
|
if ($name =~ /^[\x20-\x7E]*$/) {
|
|
# No encoding needed
|
|
push(@rv, $orig);
|
|
}
|
|
else {
|
|
# Re-encode name
|
|
my $ename = encode_mimeword($name, $encoding, $charset);
|
|
push(@rv, $ename." <".$email.">");
|
|
}
|
|
}
|
|
return join(", ", @rv);
|
|
}
|
|
|
|
# encode_mimeword(string, [encoding], [charset])
|
|
# Converts a word with 8-bit characters to MIME words format
|
|
sub encode_mimeword
|
|
{
|
|
my $word = shift;
|
|
my $encoding = uc(shift || 'Q');
|
|
my $charset = 'UTF-8';
|
|
my $encfunc = (($encoding eq 'Q') ? \&_encode_Q : \&_encode_B);
|
|
return "=?$charset?$encoding?" . &$encfunc($word) . "?=";
|
|
}
|
|
|
|
# _encode_Q STRING
|
|
# Private: used by _encode_header() to decode "Q" encoding, which is
|
|
# almost, but not exactly, quoted-printable. :-P
|
|
sub _encode_Q {
|
|
my $str = shift;
|
|
my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF";
|
|
$str =~ s{([ _\?\=$NONPRINT])}{sprintf("=%02X", ord($1))}eog;
|
|
return $str;
|
|
}
|
|
|
|
# _encode_B STRING
|
|
# Private: used by _decode_header() to decode "B" encoding.
|
|
sub _encode_B {
|
|
my $str = shift;
|
|
my $enc = &encode_base64($str);
|
|
$enc =~ s/\n//;
|
|
return $enc;
|
|
}
|
|
|
|
# user_mail_file(user|file, [other details])
|
|
sub user_mail_file
|
|
{
|
|
if ($_[0] =~ /^\//) {
|
|
return $_[0];
|
|
}
|
|
elsif ($config{'mail_dir'}) {
|
|
return &mail_file_style($_[0], $config{'mail_dir'},
|
|
$config{'mail_style'});
|
|
}
|
|
elsif (@_ > 1) {
|
|
return "$_[7]/$config{'mail_file'}";
|
|
}
|
|
else {
|
|
local @u = getpwnam($_[0]);
|
|
return "$u[7]/$config{'mail_file'}";
|
|
}
|
|
}
|
|
|
|
# mail_file_style(user, basedir, style)
|
|
# Given a directory and username, returns the path to that user's mail file
|
|
# under the directory based on the style (which may force use of parts of
|
|
# the username).
|
|
sub mail_file_style
|
|
{
|
|
if ($_[2] == 0) {
|
|
return "$_[1]/$_[0]";
|
|
}
|
|
elsif ($_[2] == 1) {
|
|
return $_[1]."/".substr($_[0], 0, 1)."/".$_[0];
|
|
}
|
|
elsif ($_[2] == 2) {
|
|
return $_[1]."/".substr($_[0], 0, 1)."/".
|
|
substr($_[0], 0, 2)."/".$_[0];
|
|
}
|
|
else {
|
|
return $_[1]."/".substr($_[0], 0, 1)."/".
|
|
substr($_[0], 1, 1)."/".$_[0];
|
|
}
|
|
}
|
|
|
|
# user_index_file(user|file)
|
|
sub user_index_file
|
|
{
|
|
local $us = $_[0];
|
|
$us =~ s/\//_/g;
|
|
local $f;
|
|
local $hn = &get_system_hostname();
|
|
if ($_[0] =~ /^\/.*\/([^\/]+)$/) {
|
|
# A file .. the index file is in ~/.usermin/mailbox or
|
|
# /etc/webmin/mailboxes
|
|
if ($user_module_config_directory && $config{'shortindex'}) {
|
|
# Use short name for index file
|
|
$f = "$user_module_config_directory/$1.findex";
|
|
}
|
|
elsif ($user_module_config_directory) {
|
|
# Under user's .usermin directory
|
|
$f = "$user_module_config_directory/$us.findex";
|
|
}
|
|
else {
|
|
# Under /var/webmin or /etc/webmin
|
|
$f = "$module_config_directory/$us.findex";
|
|
if (!glob($f."*")) {
|
|
$f = "$module_var_directory/$us.findex";
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
# A username .. the index file is in /var/webmin/modules/mailboxes or
|
|
# /etc/webmin/mailboxes
|
|
if ($user_module_config_directory) {
|
|
$f = "$user_module_config_directory/$_[0].index";
|
|
}
|
|
else {
|
|
$f = "$module_config_directory/$_[0].index";
|
|
if (!glob($f."*")) {
|
|
$f = "$module_var_directory/$_[0].index";
|
|
}
|
|
}
|
|
}
|
|
# Append hostname if requested, unless an index file without the hostname
|
|
# already exists
|
|
return $config{'noindex_hostname'} ? $f :
|
|
-r $f && !-r "$f.$hn" ? $f : "$f.$hn";
|
|
}
|
|
|
|
# extract_mail(data)
|
|
# Converts the text of a message into mail object.
|
|
sub extract_mail
|
|
{
|
|
local $text = $_[0];
|
|
$text =~ s/^\s+//;
|
|
local ($amail, @aheaders, $i);
|
|
local @alines = split(/\n/, $text);
|
|
while($i < @alines && $alines[$i]) {
|
|
if ($alines[$i] =~ /^(\S+):\s*(.*)/) {
|
|
push(@aheaders, [ $1, $2 ]);
|
|
$amail->{'rawheaders'} .= $alines[$i]."\n";
|
|
}
|
|
elsif ($alines[$i] =~ /^\s+(.*)/) {
|
|
$aheaders[$#aheaders]->[1] .= $1 unless($#aheaders < 0);
|
|
$amail->{'rawheaders'} .= $alines[$i]."\n";
|
|
}
|
|
$i++;
|
|
}
|
|
$amail->{'headers'} = \@aheaders;
|
|
foreach $h (@aheaders) {
|
|
$amail->{'header'}->{lc($h->[0])} = $h->[1];
|
|
}
|
|
splice(@alines, 0, $i);
|
|
$amail->{'body'} = join("\n", @alines)."\n";
|
|
return $amail;
|
|
}
|
|
|
|
# split_addresses(string)
|
|
# Splits a comma-separated list of addresses into [ email, real-name, original ]
|
|
# triplets
|
|
sub split_addresses
|
|
{
|
|
local (@rv, $str = $_[0]);
|
|
while(1) {
|
|
$str =~ s/\\"/\0/g;
|
|
if ($str =~ /^[\s,;]*(([^<>\(\)\s"]+)\s+\(([^\(\)]+)\))(.*)$/) {
|
|
# An address like foo@bar.com (Fooey Bar)
|
|
push(@rv, [ $2, $3, $1 ]);
|
|
$str = $4;
|
|
}
|
|
elsif ($str =~ /^[\s,;]*("([^"]*)"\s*<([^\s<>,]+)>)(.*)$/ ||
|
|
$str =~ /^[\s,;]*(([^<>\@]+)\s+<([^\s<>,]+)>)(.*)$/ ||
|
|
$str =~ /^[\s,;]*(([^<>\@]+)<([^\s<>,]+)>)(.*)$/ ||
|
|
$str =~ /^[\s,;]*(([^<>\[\]]+)\s+\[mailto:([^\s\[\]]+)\])(.*)$/||
|
|
$str =~ /^[\s,;]*(()<([^<>,]+)>)(.*)/ ||
|
|
$str =~ /^[\s,;]*(()([^\s<>,;]+))(.*)/) {
|
|
# Addresses like "Fooey Bar" <foo@bar.com>
|
|
# Fooey Bar <foo@bar.com>
|
|
# Fooey Bar<foo@bar.com>
|
|
# Fooey Bar [mailto:foo@bar.com]
|
|
# <foo@bar.com>
|
|
# <group name>
|
|
# foo@bar.com or foo
|
|
my ($all, $name, $email, $rest) = ($1, $2, $3, $4);
|
|
$all =~ s/\0/\\"/g;
|
|
$name =~ s/\0/"/g;
|
|
push(@rv, [ $email, $name eq "," ? "" : $name, $all ]);
|
|
$str = $rest;
|
|
}
|
|
else {
|
|
last;
|
|
}
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
$match_ascii = '\x1b\([BHJ]([\t\x20-\x7e]*)';
|
|
$match_jis = '\x1b\$[@B](([\x21-\x7e]{2})*)';
|
|
|
|
sub eucconv {
|
|
local($_) = @_;
|
|
if ($current_lang eq 'ja_JP.euc') {
|
|
s/$match_jis/&j2e($1)/geo;
|
|
s/$match_ascii/$1/go;
|
|
}
|
|
$_;
|
|
}
|
|
|
|
sub j2e {
|
|
local($_) = @_;
|
|
tr/\x21-\x7e/\xa1-\xfe/;
|
|
$_;
|
|
}
|
|
|
|
# eucconv_and_escape(string)
|
|
# Convert a string for display
|
|
sub eucconv_and_escape {
|
|
return &html_escape(&eucconv($_[0]));
|
|
}
|
|
|
|
# list_maildir(file, [start], [end], [headersonly])
|
|
# Returns a subset of mail from a maildir format directory
|
|
sub list_maildir
|
|
{
|
|
local (@rv, $i, $f);
|
|
&mark_read_maildir($_[0]);
|
|
local @files = &get_maildir_files($_[0]);
|
|
|
|
local ($start, $end);
|
|
if (!defined($_[1])) {
|
|
$start = 0;
|
|
$end = @files - 1;
|
|
}
|
|
elsif ($_[2] < 0) {
|
|
$start = @files + $_[2] - 1;
|
|
$end = @files + $_[1] - 1;
|
|
$start = 0 if ($start < 0);
|
|
}
|
|
else {
|
|
$start = $_[1];
|
|
$end = $_[2];
|
|
$end = @files-1 if ($end >= @files);
|
|
}
|
|
foreach $f (@files) {
|
|
if ($i < $start || $i > $end) {
|
|
# Skip files outside requested index range
|
|
push(@rv, undef);
|
|
$i++;
|
|
next;
|
|
}
|
|
local $idx = $i++;
|
|
local $mail = &read_mail_file($f, $_[3]);
|
|
if (!$mail && !$_[4]) {
|
|
# The cached Maildir file list can be stale if another client
|
|
# deleted or moved a message. Re-read it once before returning
|
|
# blank entries to the caller.
|
|
&flush_maildir_cachefile($_[0]);
|
|
return &list_maildir($_[0], $_[1], $_[2], $_[3], 1);
|
|
}
|
|
if ($mail) {
|
|
$mail->{'idx'} = $idx;
|
|
$mail->{'id'} = $f; # ID is relative path, like cur/4535534
|
|
$mail->{'id'} = substr($mail->{'id'}, length($_[0])+1);
|
|
}
|
|
push(@rv, $mail);
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
# idlist_maildir(file)
|
|
# Returns a list of files in a maildir, which form the IDs
|
|
sub idlist_maildir
|
|
{
|
|
local ($file) = @_;
|
|
&mark_read_maildir($file);
|
|
return map { substr($_, length($file)+1) } &get_maildir_files($file);
|
|
}
|
|
|
|
# select_maildir(file, &ids, headersonly)
|
|
# Returns a list of messages with the given IDs, from a maildir directory
|
|
sub select_maildir
|
|
{
|
|
local ($file, $ids, $headersonly) = @_;
|
|
local $retried = $_[3];
|
|
&mark_read_maildir($file);
|
|
local @files = &get_maildir_files($file);
|
|
local @rv;
|
|
local $missing;
|
|
foreach my $i (@$ids) {
|
|
local $path = "$file/$i";
|
|
local $mail = &read_mail_file($path, $headersonly);
|
|
if (!$mail && $path =~ /^(.*)\/(cur|tmp|new)\/([^:]*)(:2,([A-Za-z]*))?$/) {
|
|
# Flag may have changed - update path
|
|
local $suffix = "$2/$3";
|
|
local ($newfile) = grep
|
|
{ substr($_, length($file)+1, length($suffix)) eq $suffix }
|
|
@files;
|
|
if ($newfile) {
|
|
$path = $newfile;
|
|
$mail = &read_mail_file($path, $headersonly);
|
|
}
|
|
}
|
|
if (!$mail && $path =~ /\/cur\//) {
|
|
# May have moved - update path
|
|
$path =~ s/\/cur\//\/new\//g;
|
|
$mail = &read_mail_file($path, $headersonly);
|
|
}
|
|
if ($mail) {
|
|
# Set ID from corrected path
|
|
$mail->{'id'} = $path;
|
|
$mail->{'id'} = substr($mail->{'id'}, length($file)+1);
|
|
# Get index in directory
|
|
$mail->{'idx'} = &indexof($path, @files);
|
|
}
|
|
else {
|
|
$missing = 1;
|
|
}
|
|
push(@rv, $mail);
|
|
}
|
|
if ($missing && !$retried) {
|
|
&flush_maildir_cachefile($file);
|
|
return &select_maildir($file, $ids, $headersonly, 1);
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
# Get ordered list of message files (with in-memory and on-disk caching, as
|
|
# this can be slow)
|
|
# get_maildir_files(directory)
|
|
sub get_maildir_files
|
|
{
|
|
# Work out last modified time
|
|
local $newest;
|
|
foreach my $d ("$_[0]/cur", "$_[0]/new") {
|
|
local @dst = stat($d);
|
|
$newest = $dst[9] if ($dst[9] > $newest);
|
|
}
|
|
local $skipt = $config{'maildir_deleted'} || $userconfig{'maildir_deleted'};
|
|
|
|
local @files;
|
|
if (defined($main::list_maildir_cache{$_[0]}) &&
|
|
$main::list_maildir_cache_time{$_[0]} == $newest) {
|
|
# Use the in-memory cache cache
|
|
@files = @{$main::list_maildir_cache{$_[0]}};
|
|
}
|
|
else {
|
|
# Check the on-disk cache file
|
|
local $cachefile = &get_maildir_cachefile($_[0]);
|
|
local @cst = $cachefile ? stat($cachefile) : ( );
|
|
if ($cst[9] > $newest) {
|
|
# Can read the cache
|
|
open(CACHE, "<", $cachefile);
|
|
while(<CACHE>) {
|
|
chop;
|
|
push(@files, $_[0]."/".$_);
|
|
}
|
|
close(CACHE);
|
|
$main::list_maildir_cache_time{$_[0]} = $cst[9];
|
|
}
|
|
else {
|
|
# Really read
|
|
local @shorts;
|
|
foreach my $d ("cur", "new") {
|
|
&opendir_as_mail_user(DIR, "$_[0]/$d") || &error("Failed to open $_[0]/$d : $!");
|
|
while(my $f = readdir(DIR)) {
|
|
next if ($f eq "." || $f eq "..");
|
|
if ($skipt && $f =~ /:2,([A-Za-z]*T[A-Za-z]*)$/) {
|
|
# Flagged as deleted by IMAP .. skip
|
|
next;
|
|
}
|
|
push(@shorts, "$d/$f")
|
|
}
|
|
closedir(DIR);
|
|
}
|
|
@shorts = sort { substr($a, 4) cmp substr($b, 4) } @shorts;
|
|
@files = map { "$_[0]/$_" } @shorts;
|
|
|
|
# Write out the on-disk cache
|
|
if ($cachefile) {
|
|
&open_tempfile(CACHE, ">$cachefile", 1);
|
|
my $err;
|
|
foreach my $f (@shorts) {
|
|
my $ok = (print CACHE $f,"\n");
|
|
$err++ if (!$ok);
|
|
}
|
|
&close_tempfile(CACHE) if (!$err);
|
|
local @st = stat($_[0]);
|
|
if ($< == 0) {
|
|
# Cache should have some ownership as directory
|
|
&set_ownership_permissions($st[4], $st[5],
|
|
undef, $cachefile);
|
|
}
|
|
}
|
|
$main::list_maildir_cache_time{$_[0]} = $st[9];
|
|
}
|
|
$main::list_maildir_cache{$_[0]} = \@files;
|
|
}
|
|
return @files;
|
|
}
|
|
|
|
# search_maildir(file, field, what)
|
|
# Search for messages in a maildir directory, and return the results
|
|
sub search_maildir
|
|
{
|
|
return &advanced_search_maildir($_[0], [ [ $_[1], $_[2] ] ], 1);
|
|
}
|
|
|
|
# advanced_search_maildir(user|file, &fields, andmode, [&limit], [headersonly])
|
|
# Search for messages in a maildir directory, and return the results
|
|
sub advanced_search_maildir
|
|
{
|
|
&mark_read_maildir($_[0]);
|
|
local @rv;
|
|
local ($min, $max);
|
|
if ($_[3] && $_[3]->{'latest'}) {
|
|
$min = -1;
|
|
$max = -$_[3]->{'latest'};
|
|
}
|
|
local $headersonly = $_[4] && !&matches_needs_body($_[1]);
|
|
foreach $mail (&list_maildir($_[0], $min, $max, $headersonly)) {
|
|
push(@rv, $mail) if ($mail &&
|
|
&mail_matches($_[1], $_[2], $mail));
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
# mark_read_maildir(dir)
|
|
# Move any messages in the 'new' directory of this maildir to 'cur'
|
|
sub mark_read_maildir
|
|
{
|
|
local ($dir) = @_;
|
|
local @files = &get_maildir_files($dir);
|
|
local $i = 0;
|
|
foreach my $nf (@files) {
|
|
if (substr($nf, length($dir)+1, 3) eq "new") {
|
|
local $cf = $nf;
|
|
$cf =~ s/\/new\//\/cur\//g;
|
|
if (&rename_as_mail_user($nf, $cf)) {
|
|
$files[$i] = $cf;
|
|
$changed = 1;
|
|
}
|
|
}
|
|
$i++;
|
|
}
|
|
if ($changed) {
|
|
# Update the cache
|
|
$main::list_maildir_cache{$dir} = \@files;
|
|
local $cachefile = &get_maildir_cachefile($dir);
|
|
if ($cachefile) {
|
|
&open_tempfile(CACHE, ">$cachefile", 1);
|
|
foreach my $f (@files) {
|
|
local $short = substr($f, length($dir)+1);
|
|
&print_tempfile(CACHE, $short,"\n");
|
|
}
|
|
&close_tempfile(CACHE);
|
|
local @st = stat($_[0]);
|
|
if ($< == 0) {
|
|
&set_ownership_permissions($st[4], $st[5],
|
|
undef, $cachefile);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# delete_maildir(&mail, ...)
|
|
# Delete messages from a maildir directory
|
|
sub delete_maildir
|
|
{
|
|
local $m;
|
|
|
|
# Find all maildirs being deleted from
|
|
local %dirs;
|
|
foreach $m (@_) {
|
|
if ($m->{'file'} =~ /^(.*)\/(cur|new)\/([^\/]+)$/) {
|
|
$dirs{$1}->{"$2/$3"} = 1;
|
|
}
|
|
}
|
|
|
|
# Delete from caches
|
|
foreach my $dir (keys %dirs) {
|
|
local $cachefile = &get_maildir_cachefile($dir);
|
|
next if (!$cachefile);
|
|
local @cst = stat($cachefile);
|
|
next if (!@cst);
|
|
|
|
# Work out last modified time, and don't update cache if too new
|
|
local $newest;
|
|
foreach my $d ("$dir/cur", "$dir/new") {
|
|
local @dst = stat($d);
|
|
$newest = $dst[9] if ($dst[9] > $newest);
|
|
}
|
|
next if ($newest > $cst[9]);
|
|
|
|
local $lref = &read_file_lines($cachefile);
|
|
for(my $i=0; $i<@$lref; $i++) {
|
|
if ($dirs{$dir}->{$lref->[$i]}) {
|
|
# Found an entry to remove
|
|
splice(@$lref, $i--, 1);
|
|
}
|
|
}
|
|
&flush_file_lines($cachefile);
|
|
}
|
|
|
|
# Actually delete the files
|
|
foreach $m (@_) {
|
|
unlink($m->{'file'});
|
|
}
|
|
|
|
}
|
|
|
|
# modify_maildir(&oldmail, &newmail, textonly)
|
|
# Replaces a message in a maildir directory
|
|
sub modify_maildir
|
|
{
|
|
unlink($_[0]->{'file'});
|
|
&send_mail($_[1], $_[0]->{'file'}, $_[2], 1);
|
|
}
|
|
|
|
# write_maildir(&mail, directory, textonly)
|
|
# Adds some message in maildir format to a directory
|
|
sub write_maildir
|
|
{
|
|
my ($mail, $dir, $textonly) = @_;
|
|
|
|
# Work out last modified time, and don't update cache if too new
|
|
local $cachefile = &get_maildir_cachefile($dir);
|
|
local $up2date = 0;
|
|
if ($cachefile) {
|
|
local @cst = stat($cachefile);
|
|
if (@cst) {
|
|
local $newest;
|
|
foreach my $d ("$dir/cur", "$dir/new") {
|
|
local @dst = stat($d);
|
|
$newest = $dst[9] if ($dst[9] > $newest);
|
|
}
|
|
$up2date = 1 if ($newest <= $cst[9]);
|
|
}
|
|
}
|
|
|
|
# Select a unique filename and write to it
|
|
local $now = time();
|
|
$mail->{'id'} = &unique_maildir_filename($dir);
|
|
$mf = "$dir/$mail->{'id'}";
|
|
&send_mail($mail, $mf, $textonly, 1);
|
|
$mail->{'file'} = $mf;
|
|
|
|
# Set ownership of the new message file to match the directory
|
|
local @st = stat($dir);
|
|
if ($< == 0) {
|
|
&set_ownership_permissions($st[4], $st[5], undef, $mf);
|
|
}
|
|
|
|
# Create tmp and new sub-dirs, if missing
|
|
foreach my $sd ("tmp", "new") {
|
|
local $sdpath = "$dir/$sd";
|
|
if (!-d $sdpath) {
|
|
mkdir($sdpath, 0755);
|
|
if ($< == 0) {
|
|
&set_ownership_permissions($st[4], $st[5],
|
|
undef, $sdpath);
|
|
}
|
|
}
|
|
}
|
|
|
|
if ($up2date && $cachefile) {
|
|
# Bring cache up to date
|
|
$now--;
|
|
local $lref = &read_file_lines($cachefile);
|
|
push(@$lref, $mail->{'id'});
|
|
&flush_file_lines($cachefile);
|
|
}
|
|
}
|
|
|
|
# unique_maildir_filename(dir)
|
|
# Returns a filename for a new message in a maildir, relative to the directory
|
|
sub unique_maildir_filename
|
|
{
|
|
local ($dir) = @_;
|
|
mkdir("$dir/cur", 0755);
|
|
local $now = time();
|
|
local $hn = &get_system_hostname();
|
|
++$main::write_maildir_count;
|
|
local $rv;
|
|
do {
|
|
$rv = "cur/$now.$$.$main::write_maildir_count.$hn";
|
|
$now++;
|
|
} while(-r "$dir/$rv");
|
|
return $rv;
|
|
}
|
|
|
|
# empty_maildir(file)
|
|
# Delete all messages in an maildir directory
|
|
sub empty_maildir
|
|
{
|
|
local $d;
|
|
foreach $d ("$_[0]/cur", "$_[0]/new") {
|
|
local $f;
|
|
&opendir_as_mail_user(DIR, $d) || &error("Failed to open $d : $!");
|
|
while($f = readdir(DIR)) {
|
|
unlink("$d/$f") if ($f ne '.' && $f ne '..');
|
|
}
|
|
closedir(DIR);
|
|
}
|
|
&flush_maildir_cachefile($_[0]);
|
|
}
|
|
|
|
# get_maildir_cachefile(dir)
|
|
# Returns the cache file for a maildir directory
|
|
sub get_maildir_cachefile
|
|
{
|
|
local ($dir) = @_;
|
|
local $cd;
|
|
if ($user_module_config_directory) {
|
|
$cd = $user_module_config_directory;
|
|
}
|
|
else {
|
|
$cd = $module_config_directory;
|
|
if (!-r "$cd/maildircache") {
|
|
$cd = $module_var_directory;
|
|
}
|
|
}
|
|
local $sd = "$cd/maildircache";
|
|
if (!-d $sd) {
|
|
&make_dir($sd, 0755) || return undef;
|
|
}
|
|
$dir =~ s/\//_/g;
|
|
return "$sd/$dir";
|
|
}
|
|
|
|
# flush_maildir_cachefile(dir)
|
|
# Clear the on-disk and in-memory maildir caches
|
|
sub flush_maildir_cachefile
|
|
{
|
|
local ($dir) = @_;
|
|
local $cachefile = &get_maildir_cachefile($dir);
|
|
unlink($cachefile) if ($cachefile);
|
|
delete($main::list_maildir_cache{$dir});
|
|
delete($main::list_maildir_cache_time{$dir});
|
|
}
|
|
|
|
# count_maildir(dir)
|
|
# Returns the number of messages in a maildir directory
|
|
sub count_maildir
|
|
{
|
|
local @files = &get_maildir_files($_[0]);
|
|
return scalar(@files);
|
|
}
|
|
|
|
# list_mhdir(file, [start], [end], [headersonly])
|
|
# Returns a subset of mail from an MH format directory
|
|
sub list_mhdir
|
|
{
|
|
local ($start, $end, $f, $i, @rv);
|
|
&opendir_as_mail_user(DIR, $_[0]) || &error("Failed to open $_[0] : $!");
|
|
local @files = map { "$_[0]/$_" }
|
|
sort { $a <=> $b }
|
|
grep { /^\d+$/ } readdir(DIR);
|
|
closedir(DIR);
|
|
if (!defined($_[1])) {
|
|
$start = 0;
|
|
$end = @files - 1;
|
|
}
|
|
elsif ($_[2] < 0) {
|
|
$start = @files + $_[2] - 1;
|
|
$end = @files + $_[1] - 1;
|
|
$start = 0 if ($start < 0);
|
|
}
|
|
else {
|
|
$start = $_[1];
|
|
$end = $_[2];
|
|
$end = @files-1 if ($end >= @files);
|
|
}
|
|
foreach $f (@files) {
|
|
if ($i < $start || $i > $end) {
|
|
# Skip files outside requested index range
|
|
push(@rv, undef);
|
|
$i++;
|
|
next;
|
|
}
|
|
local $mail = &read_mail_file($f, $_[3]);
|
|
$mail->{'idx'} = $i++;
|
|
$mail->{'id'} = $f; # ID is message number
|
|
$mail->{'id'} = substr($mail->{'id'}, length($_[0])+1);
|
|
push(@rv, $mail);
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
# idlist_mhdir(directory)
|
|
# Returns a list of files in an MH directory, which are the IDs
|
|
sub idlist_mhdir
|
|
{
|
|
local ($dir) = @_;
|
|
&opendir_as_mail_user(DIR, $dir) || &error("Failed to open $dir : $!");
|
|
local @files = grep { /^\d+$/ } readdir(DIR);
|
|
closedir(DIR);
|
|
return @files;
|
|
}
|
|
|
|
# get_mhdir_files(directory)
|
|
# Returns a list of full paths to files in an MH directory
|
|
sub get_mhdir_files
|
|
{
|
|
local ($dir) = @_;
|
|
return map { "$dir/$_" } &idlist_mhdir($dir);
|
|
}
|
|
|
|
# select_mhdir(file, &ids, headersonly)
|
|
# Returns a list of messages with the given indexes, from an mhdir directory
|
|
sub select_mhdir
|
|
{
|
|
local ($file, $ids, $headersonly) = @_;
|
|
local @rv;
|
|
&opendir_as_mail_user(DIR, $file) || &error("Failed to open $file : $!");
|
|
local @files = map { "$file/$_" }
|
|
sort { $a <=> $b }
|
|
grep { /^\d+$/ } readdir(DIR);
|
|
closedir(DIR);
|
|
foreach my $i (@$ids) {
|
|
local $mail = &read_mail_file("$file/$i", $headersonly);
|
|
if ($mail) {
|
|
$mail->{'idx'} = &indexof("$file/$i", @files);
|
|
$mail->{'id'} = $i;
|
|
}
|
|
push(@rv, $mail);
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
# search_mhdir(file|user, field, what)
|
|
# Search for messages in an MH directory, and return the results
|
|
sub search_mhdir
|
|
{
|
|
return &advanced_search_mhdir($_[0], [ [ $_[1], $_[2] ] ], 1);
|
|
}
|
|
|
|
# advanced_search_mhdir(file|user, &fields, andmode, &limit, [headersonly])
|
|
# Search for messages in an MH directory, and return the results
|
|
sub advanced_search_mhdir
|
|
{
|
|
local @rv;
|
|
local ($min, $max);
|
|
if ($_[3] && $_[3]->{'latest'}) {
|
|
$min = -1;
|
|
$max = -$_[3]->{'latest'};
|
|
}
|
|
local $headersonly = $_[4] && !&matches_needs_body($_[1]);
|
|
foreach $mail (&list_mhdir($_[0], $min, $max, $headersonly)) {
|
|
push(@rv, $mail) if ($mail && &mail_matches($_[1], $_[2], $mail));
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
# delete_mhdir(&mail, ...)
|
|
# Delete messages from an MH directory
|
|
sub delete_mhdir
|
|
{
|
|
local $m;
|
|
foreach $m (@_) {
|
|
unlink($m->{'file'});
|
|
}
|
|
}
|
|
|
|
# modify_mhdir(&oldmail, &newmail, textonly)
|
|
# Replaces a message in a maildir directory
|
|
sub modify_mhdir
|
|
{
|
|
unlink($_[0]->{'file'});
|
|
&send_mail($_[1], $_[0]->{'file'}, $_[2], 1);
|
|
}
|
|
|
|
# max_mhdir(dir)
|
|
# Returns the maximum message ID in the directory
|
|
sub max_mhdir
|
|
{
|
|
local $max = 1;
|
|
&opendir_as_mail_user(DIR, $_[0]) || &error("Failed to open $_[0] : $!");
|
|
foreach my $f (readdir(DIR)) {
|
|
$max = $f if ($f =~ /^\d+$/ && $f > $max);
|
|
}
|
|
closedir(DIR);
|
|
return $max;
|
|
}
|
|
|
|
# empty_mhdir(file)
|
|
# Delete all messages in an MH format directory
|
|
sub empty_mhdir
|
|
{
|
|
&opendir_as_mail_user(DIR, $_[0]) || &error("Failed to open $_[0] : $!");
|
|
foreach my $f (readdir(DIR)) {
|
|
unlink("$_[0]/$f") if ($f =~ /^\d+$/);
|
|
}
|
|
closedir(DIR);
|
|
}
|
|
|
|
# count_mhdir(file)
|
|
# Returns the number of messages in an MH directory
|
|
sub count_mhdir
|
|
{
|
|
&opendir_as_mail_user(DIR, $_[0]) || &error("Failed to open $_[0] : $!");
|
|
local @files = grep { /^\d+$/ } readdir(DIR);
|
|
closedir(DIR);
|
|
return scalar(@files);
|
|
}
|
|
|
|
# list_mbxfile(file, start, end)
|
|
# Return messages from an MBX format file
|
|
sub list_mbxfile
|
|
{
|
|
local @rv;
|
|
&open_as_mail_user(MBX, $_[0]) || &error("Failed to open $_[0] : $!");
|
|
seek(MBX, 2048, 0);
|
|
while(my $line = <MBX>) {
|
|
if ($line =~ m/( \d|\d\d)-(\w\w\w)-(\d\d\d\d) (\d\d):(\d\d):(\d\d) ([+-])(\d\d)(\d\d),(\d+);([[:xdigit:]]{8})([[:xdigit:]]{4})-([[:xdigit:]]{8})\r\n$/) {
|
|
my $size = $10;
|
|
my $mail = &read_mail_fh(MBX, $size, 0);
|
|
push(@rv, $mail);
|
|
}
|
|
}
|
|
close(MBX);
|
|
return @rv;
|
|
}
|
|
|
|
# select_mbxfile(file, &ids, headersonly)
|
|
# Returns a list of messages with the given indexes, from a MBX file
|
|
sub select_mbxfile
|
|
{
|
|
local ($file, $ids, $headersonly) = @_;
|
|
local @all = &list_mbxfile($file);
|
|
local @rv;
|
|
foreach my $i (@$ids) {
|
|
push(@rv, $all[$i]);
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
# read_mail_file(file, [headersonly])
|
|
# Read a single message from a file
|
|
sub read_mail_file
|
|
{
|
|
my ($file, $headersonly) = @_;
|
|
|
|
# Open and read the mail file
|
|
&open_as_mail_user(MAIL, $file) || return undef;
|
|
my $mail = &read_mail_fh(MAIL, 0, $headersonly);
|
|
$mail->{'file'} = $file;
|
|
close(MAIL);
|
|
local @st = stat($file);
|
|
$mail->{'size'} = $st[7];
|
|
$mail->{'time'} = $st[9];
|
|
$mail->{'ctime'} = $st[10];
|
|
|
|
# Set read flags based on the name
|
|
if ($_[0] =~ /:2,([A-Za-z]*)$/) {
|
|
local @flags = split(//, $1);
|
|
$mail->{'read'} = &indexoflc("S", @flags) >= 0 ? 1 : 0;
|
|
$mail->{'special'} = &indexoflc("F", @flags) >= 0 ? 1 : 0;
|
|
$mail->{'replied'} = &indexoflc("R", @flags) >= 0 ? 1 : 0;
|
|
$mail->{'flags'} = 1;
|
|
}
|
|
|
|
return $mail;
|
|
}
|
|
|
|
# read_mail_fh(handle, [end-mode], [headersonly])
|
|
# Reads an email message from the given file handle, either up to end of
|
|
# the file, or a From line. End mode 0 = EOF, 1 = From without -,
|
|
# 2 = From possibly with -,
|
|
# higher = number of bytes
|
|
sub read_mail_fh
|
|
{
|
|
my ($fh, $endmode, $headersonly) = @_;
|
|
my @headers;
|
|
my $mail = { };
|
|
|
|
# Read the headers
|
|
my $lnum = 0;
|
|
while(1) {
|
|
$lnum++;
|
|
my $line = <$fh>;
|
|
$mail->{'size'} += length($line);
|
|
$line =~ s/\r|\n//g;
|
|
last if ($line eq '');
|
|
if ($line =~ /^(\S+):\s*(.*)/) {
|
|
push(@headers, [ $1, $2 ]);
|
|
$mail->{'rawheaders'} .= $line."\n";
|
|
}
|
|
elsif ($line =~ /^\s+(.*)/) {
|
|
$headers[$#headers]->[1] .= " ".$1 unless($#headers < 0);
|
|
$mail->{'rawheaders'} .= $line."\n";
|
|
}
|
|
elsif ($line =~ /^From\s+(\S+).*\d+/ &&
|
|
($1 ne '-' || $endmode == 2)) {
|
|
$mail->{'fromline'} = $line;
|
|
}
|
|
}
|
|
$mail->{'headers'} = \@headers;
|
|
foreach $h (@headers) {
|
|
$mail->{'header'}->{lc($h->[0])} = $h->[1];
|
|
}
|
|
|
|
if (!$headersonly) {
|
|
# Read the mail body
|
|
if ($endmode == 0) {
|
|
# Till EOF
|
|
my $bs = &get_buffer_size();
|
|
while(read($fh, $buf, $bs) > 0) {
|
|
$mail->{'size'} += length($buf);
|
|
$mail->{'body'} .= $buf;
|
|
$lc = ($buf =~ tr/\n/\n/);
|
|
$lnum += $lc;
|
|
}
|
|
close(MAIL);
|
|
}
|
|
elsif ($endmode > 2) {
|
|
# Till we have enough bytes
|
|
while($mail->{'size'} < $endmode) {
|
|
$line = <$fh>;
|
|
$lnum++;
|
|
$mail->{'size'} += length($line);
|
|
$mail->{'body'} .= $line;
|
|
}
|
|
}
|
|
else {
|
|
# Till next From line
|
|
while(1) {
|
|
$line = <$fh>;
|
|
last if (!$line || $line =~ /^From\s+(\S+).*\d+\r?\n/ &&
|
|
($1 ne '-' || $endmode == 2));
|
|
$lnum++;
|
|
$mail->{'size'} += length($line);
|
|
$mail->{'body'} .= $line;
|
|
}
|
|
}
|
|
$mail->{'lines'} = $lnum;
|
|
}
|
|
elsif ($endmode) {
|
|
# Not reading the body, but we still need to search till the next
|
|
# From: line in order to get the size
|
|
while(1) {
|
|
$line = <$fh>;
|
|
last if (!$line || $line =~ /^From\s+(\S+).*\d+\r?\n/ &&
|
|
($1 ne '-' || $endmode == 2));
|
|
$lnum++;
|
|
$mail->{'size'} += length($line);
|
|
}
|
|
$mail->{'lines'} = $lnum;
|
|
}
|
|
return $mail;
|
|
}
|
|
|
|
# dash_mode(user|file)
|
|
# Returns 1 if the messages in this folder are separated by lines like
|
|
# From - instead of the usual From foo@bar.com
|
|
sub dash_mode
|
|
{
|
|
&open_as_mail_user(DASH, &user_mail_file($_[0])) || return 0; # assume no
|
|
local $line = <DASH>;
|
|
close(DASH);
|
|
return $line =~ /^From\s+(\S+).*\d/ && $1 eq '-';
|
|
}
|
|
|
|
# mail_matches(&fields, andmode, &mail)
|
|
# Returns 1 if some message matches a search
|
|
sub mail_matches
|
|
{
|
|
local $count = 0;
|
|
local $f;
|
|
foreach $f (@{$_[0]}) {
|
|
local $field = $f->[0];
|
|
local $what = $f->[1];
|
|
local $neg = ($field =~ s/^\!//);
|
|
local $re = $f->[2] ? $what : "\Q$what\E";
|
|
if ($field eq 'body') {
|
|
$count++
|
|
if (!$neg && $_[2]->{'body'} =~ /$re/i ||
|
|
$neg && $_[2]->{'body'} !~ /$re/i);
|
|
}
|
|
elsif ($field eq 'size') {
|
|
$count++
|
|
if (!$neg && $_[2]->{'size'} > $what ||
|
|
$neg && $_[2]->{'size'} < $what);
|
|
}
|
|
elsif ($field eq 'headers') {
|
|
local $headers = $_[2]->{'rawheaders'} ||
|
|
join("", map { $_->[0].": ".$_->[1]."\n" }
|
|
@{$_[2]->{'headers'}});
|
|
$count++
|
|
if (!$neg && $headers =~ /$re/i ||
|
|
$neg && $headers !~ /$re/i);
|
|
}
|
|
elsif ($field eq 'all') {
|
|
local $headers = $_[2]->{'rawheaders'} ||
|
|
join("", map { $_->[0].": ".$_->[1]."\n" }
|
|
@{$_[2]->{'headers'}});
|
|
$count++
|
|
if (!$neg && ($_[2]->{'body'} =~ /$re/i ||
|
|
$headers =~ /$re/i) ||
|
|
$neg && ($_[2]->{'body'} !~ /$re/i &&
|
|
$headers !~ /$re/i));
|
|
}
|
|
elsif ($field eq 'status') {
|
|
$count++
|
|
if (!$neg && $_[2]->{$field} =~ /$re/i||
|
|
$neg && $_[2]->{$field} !~ /$re/i);
|
|
}
|
|
else {
|
|
$count++
|
|
if (!$neg && $_[2]->{'header'}->{$field} =~ /$re/i||
|
|
$neg && $_[2]->{'header'}->{$field} !~ /$re/i);
|
|
}
|
|
return 1 if ($count && !$_[1]);
|
|
}
|
|
return $count == scalar(@{$_[0]});
|
|
}
|
|
|
|
# search_fields(&fields)
|
|
# Returns an array of headers/fields from a search
|
|
sub search_fields
|
|
{
|
|
local @rv;
|
|
foreach my $f (@{$_[0]}) {
|
|
$f->[0] =~ /^\!?(.*)$/;
|
|
push(@rv, $1);
|
|
}
|
|
return &unique(@rv);
|
|
}
|
|
|
|
# matches_needs_body(&fields)
|
|
# Returns 1 if a search needs to check the mail body
|
|
sub matches_needs_body
|
|
{
|
|
foreach my $f (@{$_[0]}) {
|
|
return 1 if ($f->[0] eq 'body' || $f->[0] eq 'all');
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
# parse_delivery_status(text)
|
|
# Returns the fields from a message/delivery-status attachment
|
|
sub parse_delivery_status
|
|
{
|
|
local @lines = split(/[\r\n]+/, $_[0]);
|
|
local (%rv, $l);
|
|
foreach $l (@lines) {
|
|
if ($l =~ /^(\S+):\s*(.*)/) {
|
|
$rv{lc($1)} = $2;
|
|
}
|
|
}
|
|
return \%rv;
|
|
}
|
|
|
|
# parse_mail_date(string)
|
|
# Converts a mail Date: header into a unix time
|
|
sub parse_mail_date
|
|
{
|
|
local ($str) = @_;
|
|
$str =~ s/^[, \t]+//;
|
|
$str =~ s/\s+$//;
|
|
open(OLDSTDERR, ">&STDERR"); # suppress STDERR from Time::Local
|
|
close(STDERR);
|
|
my $rv = eval {
|
|
if ($str =~ /^(\S+),\s+(\d+)\s+(\S+)\s+(\d+)\s+(\d+):\s?(\d+):\s?(\d+)\s+(\S+)/) {
|
|
# Format like Mon, 13 Dec 2004 14:40:41 +0100
|
|
# or Mon, 13 Dec 2004 14:18:16 GMT
|
|
# or Tue, 14 Sep 04 02:45:09 GMT
|
|
local $tm = timegm($7, $6, $5, $2, &month_to_number($3),
|
|
$4 < 50 ? $4+100 : $4 < 1000 ? $4 : $4-1900);
|
|
local $tz = $8;
|
|
if ($tz =~ /^(\-|\+)?\d+$/) {
|
|
local $tz = int($tz);
|
|
$tz = $tz/100 if ($tz >= 50 || $tz <= -50);
|
|
$tm -= $tz*60*60;
|
|
}
|
|
return $tm;
|
|
}
|
|
elsif ($str =~ /^(\S+),\s+(\d+),?\s+(\S+)\s+(\d+)\s+(\d+):\s?(\d+):\s?(\d+)/) {
|
|
# Format like Mon, 13 Dec 2004 14:40:41 or
|
|
# Mon, 13, Dec 2004 14:40:41
|
|
# No timezone, so assume local
|
|
local $tm = timelocal($7, $6, $5, $2, &month_to_number($3),
|
|
$4 < 50 ? $4+100 : $4 < 1000 ? $4 : $4-1900);
|
|
return $tm;
|
|
}
|
|
elsif ($str =~ /^(\S+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\d+)/) {
|
|
# Format like Tue Dec 7 12:58:52 2004
|
|
local $tm = timelocal($6, $5, $4, $3, &month_to_number($2),
|
|
$7 < 50 ? $7+100 : $7 < 1000 ? $7 : $7-1900);
|
|
return $tm;
|
|
}
|
|
elsif ($str =~ /^(\S+)\s+(\S+)\s+(\d{1,2})\s+(\d+):(\d+):(\d+)/ &&
|
|
&month_to_number($2)) {
|
|
# Format like Tue Dec 7 12:58:52
|
|
local @now = localtime(time());
|
|
local $tm = timelocal($6, $5, $4, $3, &month_to_number($2),
|
|
$now[5]);
|
|
return $tm;
|
|
}
|
|
elsif ($str =~ /^(\S+)\s+(\S+)\s+(\d{1,2})\s+(\d+):(\d+)$/ &&
|
|
defined(&month_to_number($2))) {
|
|
# Format like Tue Dec 7 12:58
|
|
local @now = localtime(time());
|
|
local $tm = timelocal(0, $5, $4, $3, &month_to_number($2),
|
|
$now[5]);
|
|
return $tm;
|
|
}
|
|
elsif ($str =~ /^(\S+)\s+(\d{1,2})\s+(\d+):(\d+)$/ &&
|
|
defined(&month_to_number($1))) {
|
|
# Format like Dec 7 12:58
|
|
local @now = localtime(time());
|
|
local $tm = timelocal(0, $4, $3, $2, &month_to_number($1),
|
|
$now[5]);
|
|
return $tm;
|
|
}
|
|
elsif ($str =~ /^(\S+)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\d+)\s+(\S+)/) {
|
|
# Format like Dec 7 12:58:52 2004 GMT
|
|
local $tm = timegm($5, $4, $3, $2, &month_to_number($1),
|
|
$6 < 50 ? $6+100 : $6 < 1000 ? $6 : $6-1900);
|
|
local $tz = $7;
|
|
if ($tz =~ /^(\-|\+)?\d+$/) {
|
|
$tz = int($tz);
|
|
$tz = $tz/100 if ($tz >= 50 || $tz <= -50);
|
|
$tm -= $tz*60*60;
|
|
}
|
|
return $tm;
|
|
}
|
|
elsif ($str =~ /^(\d{4})\-(\d+)\-(\d+)\s+(\d+):(\d+)/) {
|
|
# Format like 2004-12-07 12:53
|
|
local $tm = timelocal(0, $4, $4, $3, $2-1,
|
|
$1 < 50 ? $1+100 : $1 < 1000 ? $1 : $1-1900);
|
|
return $tm;
|
|
}
|
|
elsif ($str =~ /^(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\S+)/) {
|
|
# Format like 30 Jun 2005 21:01:01 -0000
|
|
local $tm = timegm($6, $5, $4, $1, &month_to_number($2),
|
|
$3 < 50 ? $3+100 : $3 < 1000 ? $3 : $3-1900);
|
|
local $tz = $7;
|
|
if ($tz =~ /^(\-|\+)?\d+$/) {
|
|
$tz = int($tz);
|
|
$tz = $tz/100 if ($tz >= 50 || $tz <= -50);
|
|
$tm -= $tz*60*60;
|
|
}
|
|
return $tm;
|
|
}
|
|
elsif ($str =~ /^(\d+)\/(\S+)\/(\d+)\s+(\d+):(\d+)/) {
|
|
# Format like 21/Feb/2008 24:13
|
|
local $tm = timelocal(0, $5, $4, $1, &month_to_number($2),
|
|
$3-1900);
|
|
return $tm;
|
|
}
|
|
else {
|
|
return undef;
|
|
}
|
|
};
|
|
open(STDERR, ">&OLDSTDERR");
|
|
close(OLDSTDERR);
|
|
if ($@) {
|
|
#print STDERR "parsing of $str failed : $@\n";
|
|
return undef;
|
|
}
|
|
return $rv;
|
|
}
|
|
|
|
# send_text_mail(from, to, cc, subject, body, [smtp-server],
|
|
# [smtp-user, smtp-pass])
|
|
# A convenience function for sending a email with just a text body
|
|
sub send_text_mail
|
|
{
|
|
local ($from, $to, $cc, $subject, $body, $smtp, $user, $pass) = @_;
|
|
local $cs = &get_charset();
|
|
local $attach =
|
|
{ 'headers' => [ [ 'Content-Type', 'text/plain; charset='.$cs ],
|
|
[ 'Content-Transfer-Encoding', 'quoted-printable' ] ],
|
|
'data' => "ed_encode($body) };
|
|
local $mail = { 'headers' =>
|
|
[ [ 'From', $from ],
|
|
[ 'To', $to ],
|
|
[ 'Cc', $cc ],
|
|
[ 'Subject', &encode_mimewords($subject) ] ],
|
|
'attach' => [ $attach ] };
|
|
return &send_mail($mail, undef, 1, 0, $smtp, $user, $pass);
|
|
}
|
|
|
|
# make_from_line(address, [time])
|
|
# Returns a From line for mbox emails, based on the current time
|
|
sub make_from_line
|
|
{
|
|
local ($addr, $t) = @_;
|
|
$t ||= time();
|
|
&clear_time_locale();
|
|
local $rv = "From $addr ".strftime("%a %b %e %H:%M:%S %Y", localtime($t));
|
|
&reset_time_locale();
|
|
return $rv;
|
|
}
|
|
|
|
sub notes_decode
|
|
{
|
|
# Deprecated - does nothing
|
|
}
|
|
|
|
# add_mailer_ip_headers(&headers)
|
|
# Add X-Mailer and X-Originating-IP headers, if enabled
|
|
sub add_mailer_ip_headers
|
|
{
|
|
local ($headers) = @_;
|
|
if (!$config{'no_orig_ip'}) {
|
|
push(@$headers, [ 'X-Originating-IP', $ENV{'REMOTE_ADDR'} ]);
|
|
}
|
|
if (!$config{'no_mailer'}) {
|
|
push(@$headers, [ 'X-Mailer', ucfirst(&get_product_name())." ".
|
|
&get_webmin_version() ]);
|
|
}
|
|
}
|
|
|
|
# set_mail_open_user(user)
|
|
# Sets the Unix user that will be used for all mail file open ops, by functions
|
|
# like list_mail and select_maildir
|
|
sub set_mail_open_user
|
|
{
|
|
my ($user) = @_;
|
|
if ($user eq "root" || $user eq "0") {
|
|
$main::mail_open_user = undef;
|
|
}
|
|
elsif (!$<) {
|
|
$main::mail_open_user = $user;
|
|
}
|
|
}
|
|
|
|
# clear_mail_open_user()
|
|
# Resets the user to root
|
|
sub clear_mail_open_user
|
|
{
|
|
my ($user) = @_;
|
|
$main::mail_open_user = undef;
|
|
}
|
|
|
|
# open_as_mail_user(fh, file)
|
|
# Calls the open function, but as the user set by set_mail_open_user
|
|
sub open_as_mail_user
|
|
{
|
|
my ($fh, $file) = @_;
|
|
my $switched = &switch_to_mail_user();
|
|
my $mode = "<";
|
|
if ($file =~ s/^(<|>>|>|\|)//) {
|
|
$mode = $1;
|
|
}
|
|
my $rv = open($fh, $mode, $file);
|
|
if ((!$mode || $mode eq "<") && $rv) {
|
|
# Is it compressed? If so, switch to reading via gzip
|
|
my $two;
|
|
read($fh, $two, 2);
|
|
seek($fh, 0, 0);
|
|
if ($two eq "\037\213") {
|
|
# Gzipped .. need to read-open
|
|
close($fh);
|
|
open($fh, "gunzip -c ".quotemeta($file)." |");
|
|
}
|
|
}
|
|
if ($switched) {
|
|
# Now that it is open, switch back to root
|
|
$) = 0;
|
|
$> = 0;
|
|
}
|
|
return $rv;
|
|
}
|
|
|
|
# is_gzipped_file(file)
|
|
# Returns 1 if a file is gzip compressed
|
|
sub is_gzipped_file
|
|
{
|
|
my ($file) = @_;
|
|
my $fh;
|
|
my $rv = open($fh, "<", $file);
|
|
return 0 if (!$rv);
|
|
my $two;
|
|
read($fh, $two, 2);
|
|
close($fh);
|
|
return $two eq "\037\213" ? 1 : 0;
|
|
}
|
|
|
|
# gunzip_mail_file(file)
|
|
# Uncompress a mail file in place
|
|
sub gunzip_mail_file
|
|
{
|
|
my ($file) = @_;
|
|
my $switched = &switch_to_mail_user();
|
|
my $outfile = $file.".$$.uncompressed";
|
|
my @st = stat($file);
|
|
my $ex = system("gunzip -c ".quotemeta($file)."> ".quotemeta($outfile)." 2>/dev/null");
|
|
if ($ex) {
|
|
unlink($outfile);
|
|
}
|
|
else {
|
|
rename($outfile, $file);
|
|
&set_ownership_permissions($st[4], $st[5], $st[2], $file);
|
|
utime($st[8], $st[9], $file);
|
|
}
|
|
if ($switched) {
|
|
$) = 0;
|
|
$> = 0;
|
|
}
|
|
return !$ex;
|
|
}
|
|
|
|
# create_as_mail_user(fh, file)
|
|
# Creates a new file, but ensures that it does not yet exist first, and then
|
|
# sets the ownership to the mail user
|
|
sub create_as_mail_user
|
|
{
|
|
my ($fh, $file) = @_;
|
|
if (&should_switch_to_mail_user()) {
|
|
# Open the file as root, but ensure that it doesn't exist yet. Then
|
|
# make it owned by the user
|
|
$file =~ s/^>+//;
|
|
my $rv = sysopen($fh, $file, O_CREAT|O_WRONLY, 0700);
|
|
return $rv if (!$rv);
|
|
my @uinfo = &get_switch_user_info();
|
|
&set_ownership_permissions($uinfo[2], $uinfo[3], undef, $file);
|
|
return $rv;
|
|
}
|
|
else {
|
|
# Operating as root, so no special behaviour needed
|
|
if ($file =~ /^(<|>)/) {
|
|
return open($fh, $file);
|
|
}
|
|
else {
|
|
return open($fh, "<", $file);
|
|
}
|
|
}
|
|
}
|
|
|
|
# opendir_as_mail_user(fh, dir)
|
|
# Calls the opendir function, but as the user set by set_mail_open_user
|
|
sub opendir_as_mail_user
|
|
{
|
|
my ($fh, $dir) = @_;
|
|
my $switched = &switch_to_mail_user();
|
|
my $rv = opendir($fh, $dir);
|
|
if ($switched) {
|
|
$) = 0;
|
|
$> = 0;
|
|
}
|
|
return $rv;
|
|
}
|
|
|
|
# rename_as_mail_user(old, new)
|
|
# Like the rename function, but as the user set by set_mail_open_user
|
|
sub rename_as_mail_user
|
|
{
|
|
my ($oldfile, $newfile) = @_;
|
|
my $switched = &switch_to_mail_user();
|
|
my $rv = &rename_file($oldfile, $newfile);
|
|
if ($switched) {
|
|
$) = 0;
|
|
$> = 0;
|
|
}
|
|
return $rv;
|
|
}
|
|
|
|
# mkdir_as_mail_user(path, perms)
|
|
# Like the mkdir function, but as the user set by set_mail_open_user
|
|
sub mkdir_as_mail_user
|
|
{
|
|
my ($path, $perms) = @_;
|
|
my $switched = &switch_to_mail_user();
|
|
my $rv = mkdir($path, $perms);
|
|
if ($switched) {
|
|
$) = 0;
|
|
$> = 0;
|
|
}
|
|
return $rv;
|
|
}
|
|
|
|
# unlink_as_mail_user(path)
|
|
# Like the unlink function, but as the user set by set_mail_open_user
|
|
sub unlink_as_mail_user
|
|
{
|
|
my ($path) = @_;
|
|
my $switched = &switch_to_mail_user();
|
|
my $rv = unlink($path);
|
|
if ($switched) {
|
|
$) = 0;
|
|
$> = 0;
|
|
}
|
|
return $rv;
|
|
}
|
|
|
|
# copy_source_dest_as_mail_user(source, dest)
|
|
# Copy a file, with perms of the user from set_mail_open_user
|
|
sub copy_source_dest_as_mail_user
|
|
{
|
|
my ($src, $dst) = @_;
|
|
if (&should_switch_to_mail_user()) {
|
|
&open_as_mail_user(SRC, $src) || return 0;
|
|
&open_as_mail_user(DST, ">$dst") || return 0;
|
|
my $buf;
|
|
my $bs = &get_buffer_size();
|
|
while(read(SRC, $buf, $bs) > 0) {
|
|
print DST $buf;
|
|
}
|
|
close(SRC);
|
|
close(DST);
|
|
return 1;
|
|
}
|
|
else {
|
|
return ©_source_dest($src, $dst);
|
|
}
|
|
}
|
|
|
|
# chmod_as_mail_user(perms, file, ...)
|
|
# Set file permissions, but with perms of the user from set_mail_open_user
|
|
sub chmod_as_mail_user
|
|
{
|
|
my ($perms, @files) = @_;
|
|
my $switched = &switch_to_mail_user();
|
|
my $rv = chmod($perms, @files);
|
|
if ($switched) {
|
|
$) = 0;
|
|
$> = 0;
|
|
}
|
|
return $rv;
|
|
}
|
|
|
|
# should_switch_to_mail_user()
|
|
# Returns 1 if file IO will be done as a mail owner user
|
|
sub should_switch_to_mail_user
|
|
{
|
|
return defined($main::mail_open_user) && !$< && !$>;
|
|
}
|
|
|
|
# switch_to_mail_user()
|
|
# Sets the permissions used for reading files
|
|
sub switch_to_mail_user
|
|
{
|
|
if (&should_switch_to_mail_user()) {
|
|
# Switch file permissions to the correct user
|
|
my @uinfo = &get_switch_user_info();
|
|
@uinfo || &error("Mail open user $main::mail_open_user ".
|
|
"does not exist");
|
|
$) = $uinfo[3]." ".join(" ", $uinfo[3], &other_groups($uinfo[0]));
|
|
$> = $uinfo[2];
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
# get_switch_user_info()
|
|
# Returns the getpw* function array for the user to switch to
|
|
sub get_switch_user_info
|
|
{
|
|
my $user = @_ ? $_[0] : $main::mail_open_user;
|
|
if ($user =~ /^\d+$/) {
|
|
# Could be by UID .. but fall back to by name if there is no such UID
|
|
my @rv = getpwuid($user);
|
|
return @rv if (@rv > 0);
|
|
}
|
|
return getpwnam($user);
|
|
}
|
|
|
|
# is_ascii()
|
|
# Checks if string is ASCII
|
|
sub is_ascii {
|
|
my ($str) = @_;
|
|
my $str_ = $str;
|
|
utf8::encode($str_);
|
|
if ($str eq $str_) {
|
|
return 1;
|
|
}
|
|
else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
1;
|