# vim: set cindent expandtab ts=4 sw=4:
#
# Copyright (c) 1998-2005 Chi-Keung Ho. All rights reserved.
#
# This programe is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# Extmail - a high-performance webmail to maildir
# $Id$
package Ext::Storage::Maildir;
use strict;
# Maildir++ specification
# see http://www.inter7.com/courierimap/README.maildirquota.html
#
# Contents of maildirsize
# maildirsize contains two or more lines terminated by newline characters.
#
# The first line contains a copy of the quota definition as used by the
# system's mail server. Each application that uses the maildir must know
# what it's quota is. Instead of configuring each application with the
# quota logic, and making sure that every application's quota definition
# for the same maildir is exactly the same, the quota specification used
# by the system mail server is saved as the first line of the maildirsize
# file. All other application that enforce the maildir quota simply read
# the first line of maildirsize.
#
# The quota definition is a list, separate by commas. Each member of the
# list consists of an integer followed by a letter, specifying the nature
# of the quota. Currently defined quota types are 'S' - total size of all
# messages, and 'C' - the maximum count of messages in the maildir.
#
# For example, 10000000S,1000C specifies a quota of 10,000,000 bytes or
# 1,000 messages, whichever comes first.
#
# All remaining lines all contain two integers separated by a single space.
# The first integer is interpreted as a byte count. The second integer is
# interpreted as a file count. A Maildir++ writer can add up all byte
# counts and file counts from maildirsize and enforce a quota based either
# on number of messages or the total size of all the messages.
#
# Maildir specification
# see http://cr.yp.to/proto/maildir.html
# Update 2005-07-28, experimantal OO design, now use global varibles to
# store configuration and some information instead of using object, for
# performance reason. OO object new/del a hundred thousand times will
# be much slower than direct reference :-(
use Fcntl ':flock';
use Exporter;
use vars qw(@ISA @EXPORT %CFG $SORTORDER);
@ISA = qw(Exporter);
@EXPORT = qw(
mk_maildir rm_maildir get_quota get_curquota reset_quota
re_calculate update_quota is_overquota scan_dir get_dirs_list
get_msgs_list get_msgs_cache set_msgs_cache get_dir_cnt
check_new is_new get_status set_status is_subdir _name2mdir
pos2file update_bmsgs_cache get_bmsgs_cache set_msg_seen
set_bmsgs_delete set_bmsgs_move parse_curcnt maildir_find
update_quota_s gen_std_maildir has_attach get_sortorder
rebuild_msgs_cache is_sys_maildir valid_maildir mv_maildir
valid_dirname purge_maildir check_curcnt);
%CFG=();
use Ext::MIME; # _set_msgs_cache use it
use Ext::Utils qw(untaint _index _substr _length human_size);
use Ext::RFC822 qw(str2time); # import str2time
use Ext::DateTime qw(datefield2dateserial);
use constant CACHE_CNT_LIFE => 7200; # 60 minutes to renew cnt
use constant CACHE_CUR_LIFE => 7200; # 60 minutes to rebuild curcache
# init - init a Maildir, for read/write and quota maintains
sub init {
my ($path, $mode, $warnlv) = @_;
# XXX the magic to set default permission
umask(0077);
$CFG{path} = $path ? $path : "."; # relative path
$CFG{mode} = $mode ? $mode : "O_RW";
$CFG{warnlv} = $warnlv ? $warnlv : "0.9"; # 90% default
chdir($CFG{path}) or die "Can't chdir to $CFG{path}, $!\n";
mkdir "cur", 0700 if(!-d 'cur');
mkdir "new", 0700 if(!-d 'new');
mkdir "tmp", 0700 if(!-d 'tmp');
# Check the default subdir and create them if not present
mk_maildir('.Sent') if(!-d '.Sent');
mk_maildir('.Drafts') if(!-d '.Drafts');
mk_maildir('.Trash') if(!-d '.Trash');
mk_maildir('.Junk') if(!-d '.Junk');
if(! -e $CFG{path}.'/maildirsize') {
re_calculate();
}
# re-calculate if more than 5120 bytes
if((stat $CFG{path}.'/maildirsize')[7] >= 5120) {
re_calculate();
}
1;
}
# mk_maildir - create maildir
sub mk_maildir {
my $folder = _name2mdir($_[0]);
return 0 unless valid_dirname($folder);
return 0 if(-d $folder);
$folder = untaint($folder);
mkdir $folder, 0700;
_touch("$folder/maildirfolder");
mkdir "$folder/cur", 0700 if(!-d "$folder/cur");
mkdir "$folder/new", 0700 if(!-d "$folder/new");
mkdir "$folder/tmp", 0700 if(!-d "$folder/tmp");
1;
}
# rm_maildir - delete maildir
sub rm_maildir {
my $folder = $_[0];
my $flag = $_[1];
# not need to check folder name if $flag, because
# it's internal function call, not called by other module
return 0 if (!$flag && !valid_dirname($folder));
$folder = _name2mdir($folder) unless($flag);
if($folder =~/^\.(Inbox|Sent|Drafts|Trash|Junk|\.)$/) {
# Ignore default folder
return 0;
}
if(-d $folder) {
my @entries = ();
opendir DIR, $folder or die "Can't opendir, $!\n";
@entries = grep { !/^\.$/ && !/^\..$/ } readdir(DIR);
closedir DIR;
for my $f (@entries) {
if(-d "$folder/$f") {
# the $flag is to indicate that whether we
# are in recursive mode, if yes ignore all checks
rm_maildir("$folder/$f", 1);
next;
}
unlink untaint("$folder/$f");
}
rmdir untaint($folder); # this remove dir left
return 1;
}
0;
}
sub mv_maildir {
my ($from, $to) = @_;
# folder name not valid? just return
return 0 if (!valid_dirname($to) || !valid_dirname($from));
$from = _name2mdir($from);
$to = _name2mdir($to);
if ($from =~ /^\.(Inbox|Sent|Drafts|Trash|Junk|\.)$/ ||
$to =~ /^\.(Inbox|Sent|Drafts|Trash|Junk|\.)$/) {
return 0;
}
if (-d $to) {
return 0;
}
rename (untaint($from) , untaint($to)); # rename
return 1;
}
sub purge_maildir {
my $folder = $_[0];
return 0 if (!valid_dirname($folder));
$folder = _name2mdir($folder);
if($folder =~/^\.(Inbox|Sent|Drafts|\.)$/) {
# Ignore default folder
return 0;
}
if(-d $folder) {
for my $dir (qw(cur tmp new)) {
my @entries = ();
opendir DIR, "$folder/$dir" or die "Can't opendir, $!\n";
@entries = grep { !/^\.$/ && !/^\..$/ } readdir(DIR);
closedir DIR;
for my $f (@entries) {
unlink untaint("$folder/$dir/$f");
}
}
for my $f (qw(extmail-curcache.db extmail-curcnt)) {
unlink "$folder/$f";
}
return 1;
}
0;
}
# get_quota - to get a Maildir quota limitation info, return a HASH
sub get_quota {
my $path = $CFG{path};
my ($smax, $cmax);
# Update 2005-07-26, check maildirsize first, fallback to
# $ENV{DEFAULT_QUOTA} if not present.
if(-e "$path/maildirsize") {
open(my $FD, "< $path/maildirsize") or
die "Can't open maildirsize, $!\n";
$_=<$FD> || "";
close FD;
}elsif($ENV{QUOTA}) {
$_=$ENV{QUOTA};
}else {
$_=$ENV{DEFAULT_QUOTA};
}
if(!length($_)) {
return {
size => undef,
count => undef
}
}
if(/(\d+)C/i) {
# has a count quota
$cmax = $1;
}elsif(/(\d+)S/i) {
# has a size quota
$smax = $1;
}
return {
size =>$smax,
count => $cmax
}; # return a ref of HASH
}
# get_curquota - to get current quota usage, return a ARRAY not HASH
sub get_curquota {
my $path = $CFG{path};
my ($size, $cnt) = (0,0);
open(FD, "<$path/maildirsize") or
die "Can't open maildirsize, $!\n";
my $s = <FD>; # omit the first line;
seek(FD,0,0) unless($s=~/S|C/); # unget if no quota limit
while(<FD>) {
chomp;
/\s*([\-]*\d+)\s+([\-]*\d+)/;
$cnt = $cnt+$2;
$size = $size+$1; # include -xxx, perl will automaticlly
# handle nagetive value :)
}
return {
size => $size,
count => $cnt
}; # return a ref of HASH
}
# set_quota - reset quota to a new value, mostly used by ADMIN API
sub reset_quota {
my ($q_size, $q_cnt) = @_;
my $path = $CFG{path};
open(FD, "< $path/maildirsize") or
die "Can't open maildirsize, $!\n";
my $s = <FD>;# omit the first line
seek(FD,0,0) unless($s=~/S|C/); # unget if no quota limit
local $/= undef;
$s = <FD>;
close FD;
open(FD, "> $path/tmp/maildirsize.tmp") or
die "Can't open maildirsize.tmp for write, $!\n";
print FD "$q_size"."S";
if($q_cnt) {
print FD ",$q_cnt"."C";
}
print FD "\n"; # newline
print FD $s;
close FD;
unlink untaint("$path/maildirsize") || die "unlink fail: $!\n";
rename untaint($path."/tmp/maildirsize.tmp"), untaint($path."/maildirsize") or
die "Can't rename:$!\n";
1;
}
sub re_calculate {
open(my $FD, "> $CFG{path}/tmp/maildirsize.tmp") or
die "Can't open maildirsize.tmp: $!\n";
my $inf = get_quota;
if($inf->{size} and $inf->{count}) {
print $FD $inf->{size}."S,".$inf->{count}."C\n";
}elsif($inf->{size}) {
print $FD $inf->{size}."S\n";
}elsif($inf->{count}) {
print $FD $inf->{count}."C\n";
}
close $FD;
$inf = scan_dir();
$CFG{mdspath} = $CFG{path}."/tmp/maildirsize.tmp";
update_quota($inf->{size}, $inf->{new}+$inf->{seen});
delete $CFG{mdspath}; # clean it after usage
rename (untaint($CFG{path}."/tmp/maildirsize.tmp"),
untaint($CFG{path}."/maildirsize"))
or die "Can't rename maildirsize, $!\n";
}
# update_quota - do an append action to maildirsize file.
sub update_quota {
my ($size, $count) = @_;
my $file = defined $CFG{mdspath} ?
$CFG{mdspath}: $CFG{path}.'/maildirsize';
$file = untaint ($file);
open(FD, ">> $file") or
die "Can't open maildirsize, $!\n";
flock(FD, LOCK_EX);
my $str = _fmt2mds($size, $count);
print FD $str;
flock(FD, LOCK_UN);
close FD;
# after update, check maildirsize file size;
if((stat $file)[7] >= 5120) {
re_calculate();
}
}
# update_quota_s - update bunch of quota records
sub update_quota_s {
my $ref = $_[0];
my $file = defined $CFG{mdspath} ?
$CFG{mdspath}: $CFG{path}.'/maildirsize';
$file = untaint ($file);
open(my $FD, ">> $file") or
die "Can't open maildirsize, $!\n";
flock($FD, LOCK_EX);
foreach(keys %$ref) {
my($s,$c) = split(/\s/, $ref->{$_});
my $str = _fmt2mds($s,$c);
print $FD $str;
}
flock($FD, LOCK_UN);
close $FD;
# after update, check maildirsize file size;
if((stat $file)[7] >= 5120) {
re_calculate();
}
}
# _fmt2mds format given params into maildirsize record
sub _fmt2mds {
my $smaxlen = 8; # recommand 10 digitals
my $cmaxlen = 5; # recommand 6 digitals
my $put = "";
my($s,$c) = @_; # size can be nagetive, like -1260
if(length($s) < $smaxlen) {
my $delta = $smaxlen - length($s);
$put .= " " x $delta . "$s";
}else {
$put .="$s";
}
if(length($c) < $cmaxlen) {
my $delta = $cmaxlen - length($c);
$put .=" ". " " x $delta . "$c";
}else {
$put .=" $c";
}
return "$put\n";
}
# is_overquota - check whether a Maildir is over quota, need get_quota
# this function will automatically set overquota flag to a file:
# $HOME/Maildir/quotawarn.
#
# Tricks: if any of (size, count) is 'undef' or '0', means no limit!
#
# Update: 2005-07-31 use SOFT/HARD_OVER to identify whether a maildir
# is nearly overquota or already overquota
#
# 2005-08-05 add two params to calculate where it's overquota, while
# writing a new email
use constant NO_OVERQT => 0;
use constant SOFT_OVER => 1;
use constant HARD_OVER => 2;
sub is_overquota {
my ($addsize, $addcnt) = @_;
my $cur = get_curquota();
my ($q_size, $q_cnt);
my $sig = 0; # XXX NOT_OVER
my $inf = get_quota();
$q_size = $inf->{size} ? $inf->{size} : 0;
$q_cnt = $inf->{count} ? $inf->{count} : 0;
$cur->{size} += $addsize if(defined $addsize && $addsize>0);
$cur->{count} += $addcnt if(defined $addcnt && $addcnt>0);
if($q_cnt) { # quota set
if($cur->{count} >= $q_cnt) {
$sig = 2; # XXX HARD_OVER
}elsif($cur->{count} >= int($q_cnt*$CFG{warnlv})) {
$sig = 1; # XXX SOFT_OVER
}
}
if($q_size) { # quota set
# XXX all SOFT_OVER
unless ($sig>1) { # if not HARD_OVER
if($cur->{size} >= $q_size) { # HARD_OVER
$sig = 2;
}else {
if($cur->{size} >= $q_size*$CFG{warnlv}) {
$sig = 1;
}
}
}
}
if($sig) {
_touch("quotawarn");
}else {
my $qf = $CFG{path}.'/quotawarn';
if(-e $qf) {
unlink untaint($qf);
}
}
$sig;
}
# Maildir files and messages handl func*
#
# Scheme defination:
# 2 types of special folders, Inbox and SubBox. typeglob:
#
# $maildir/cur
# $maildir/new
# $maildir/tmp
# $maildir/.Drafts/cur
# $maildir/.Drafts/new
# $maildir/.Drafts/tmp
#
# subBox of subBox:
# $maildir/.SubBox1/cur
# $maildir/.SubBox1/new
# $maildir/.SubBox1/tmp
# $maildir/.SubBox1::SubBox2/cur
# $maildir/.SubBox1::SubBox2/new
# $maildir/.SubBox1::SubBox2/tmp
#
# So we provide several func* to get the following info:
# 1) Total of sizes, seens, news => scan_dir();
# 2) A certain SubBox's size, seen, new => get_dir_cnt($dir);
# 3) Inbox size, seen, new => get_dir_cnt('Inbox');
sub scan_dir {
my @dir = get_dirs_list();
my ($new, $seen, $tsize) = (0,0,0);
# Include Inbox, in fact that append a "."
foreach(@dir) {
check_new($_);
my $inf = get_dir_cnt($_);
$new = $new + $inf->{new};
$seen = $seen + $inf->{seen};
$tsize = $tsize + $inf->{size};
}
return {
new => $new,
seen => $seen,
size => $tsize
}; # return a ref
}
# get_dirs_list - a public func to get a formated folder/subfolders list
sub get_dirs_list {
my @dir = _get_dirs_list();# only get the none sysdefault dir :)
my @sysdir = ("Inbox", "Sent", "Drafts", "Trash", "Junk");
unshift @dir, @sysdir;
@dir;
}
# _get_dirs_list - get the whole Maildir++ folder/subfolder list
# exclude the special "INBOX", "Trash", "Drafts", "Sent", "Junk"
sub _get_dirs_list {
my $path = $CFG{path};
opendir DIR, $path || die "Can't opendir $path, $!\n";
my @dir = sort {$a cmp $b} grep {
!/^\.Drafts$/ && !/^\.Sent$/ && !/^\.Junk$/
&& !/^\.Trash$/ && !/^\.$/ && !/^\..$/
&& -d $_ && -e "$_/maildirfolder"
} readdir DIR; # assume that we've chdir!!
close DIR;
$dir[$_]=~ s/^\.// for(0...$#dir);
@dir;
}
# get_msg_list - get an ref to ARRAY to lists the specify dir
sub get_msgs_list {
my $dir = _name2mdir($_[0]);
return _get_msgs_list($dir);
}
sub _get_msgs_list {
my $dir = $CFG{path}."/$_[0]/cur";
#_check_new($_[0]);
opendir DIR, $dir || die "Can't opendir $dir, $!\n";
my @f = grep { !/^\./ } readdir DIR;
close DIR;
\@f; # return a ref ARRAY :-)
}
# MSG_CACHE handle functions
#
# the following routines handle most of curcache operation, include:
# 1) get the seen/new counts of a certain dir, eg: Inbox
# 2) get the savetime of cache file
# 3) get the specify msgs cache info in a certain offset.
# 3) get a bunch of msgs cache information base on pos ids.
#
# XXX CACHE design
#
# XXX HEAD:
#
# SAVETIME=%s\n * cache savetime
# COUNT=%s\n * seen messages count
# NEWCOUNT=%s\n * unseen messages count
# SORT=%s\n * sort method
# VERSION=%s\n * the cache algorithm version
#
# XXX REC$i:
#
# FILENAME=%s\n
# FROM=%s\n
# TO=%s\n * multiple values concat with space
# SUBJECT=%s\n
# SIZES=%s\n
# DATE=%s\n
# DATETIME=%s\n * result of str2time($DATE)
# STATUS=%s\n
# TIME=%s\n
# INODE=%s\n
# CONTENTTYPE=%s\n * the content type
# CHARSET=%s\n * the charset found in header
# LABEL=%s\n * marked as a certain label
# EXTENSION=%s\n * for future use
sub get_msgs_cache {
my ($fd, $nfiles, $pos) = @_;
my $cache_file = $CFG{path}.'/'._name2mdir($fd).'/extmail-curcache.db';
if(-r $cache_file) {
use Ext::DB;
my %hash = ();
my $db = Ext::DB->new(file => "Btree:$cache_file");
my $info = _parse_cache($db->lookup('HEADER'));
my $end = ($pos+$nfiles)>= ($info->{COUNT}+$info->{NEWCOUNT}) ?
$info->{COUNT}+$info->{NEWCOUNT} : $pos+$nfiles;
# update in 2005-08-19, return a flag to indicate whether
# there are more entires in cache
my $nomore = ($pos+$nfiles)>= ($info->{COUNT}+$info->{NEWCOUNT}) ?
1 : 0;
foreach(my $i=$pos; $i<$end; $i++) {
$hash{$i} = _parse_cache($db->lookup("REC$i"));
}
return (\%hash, $nomore);
}else {
die "Can't read $cache_file, $!\n";
}
1;
}
# get a bunch msgs cache info, useful while implementing setting a bunch
# of msgs to READED or UNREAD, or other type. But this task can be imple-
# mented by focusing on file name FLAG, etc.
sub get_bmsgs_cache {
my ($fd, @pos) = @_;
my $cache_file = $CFG{path}.'/'._name2mdir($fd).'/extmail-curcache.db';
if(-r $cache_file) {
use Ext::DB;
my %hash = ();
my $db = Ext::DB->new(file => "Btree:$cache_file");
foreach(@pos) {
$hash{$_} = _parse_cache($db->lookup("REC$_"));
}
return \%hash;
}else {
die "Can't read $cache_file, $!\n";
}
1;
}
# update_bmsgs_cache - update msgs filename(flag) and etc..
# format: $hash => key => pos, value => FLAG(+/- A-Z)
sub update_bmsgs_cache {
my ($fd, %hash) = @_;
my $cache_file = $CFG{path}.'/'._name2mdir($fd).'/extmail-curcache.db';
if(-r $cache_file) {
use Ext::DB;
my $db = Ext::DB->new(
file => "Btree:$cache_file",
flags => 'write');
foreach my $pos (keys %hash) {
$db->update("REC$pos", $hash{$pos});
}
return 1;
}else {
return 0;
}
}
sub pos2file {
my ($fd, $pos) = @_;
my $cache = get_bmsgs_cache($fd, $pos);
$cache->{$pos}->{'FILENAME'};
}
sub gen_std_maildir {
my $tmpfile = shift;
my $time = _gen_time_part();
my @a = _gen_file_part($tmpfile);
return $time.'P'.$$.'V'.$a[0].'I'.$a[1];
}
sub _length_fmt {
my ($s, $len) = @_;
my $delta = 0;
if(length($s)<$len) {
$delta = $len - length($s);
}
return ('0' x $delta).$s;
}
sub _gen_time_part {
eval {
require 'sys/syscall.ph';
};
if($@) { return time; }
return time unless (defined &SYS_gettimeofday);
my $start = pack('LL', ());
syscall(&SYS_gettimeofday, $start, 0) != -1
or die "gettimeofday: $!";
my @start = unpack('LL', $start);
return $start[0].'.M'.$start[1];
}
sub _gen_file_part {
my @a = map { uc(sprintf "%x",$_) } (stat $_[0])[0,1];
my $dev = _length_fmt($a[0], 16);
my $inode = _length_fmt($a[1], 8);
return($dev, $inode);
}
# this function is very important while a given message filename
# not actually exist in cache, it will try to search a file, which
# is most to be close to the given name.
sub maildir_find {
my ($fd, $file) = @_;
return "" unless($file); # check $file null or not
return $file if (-r _name2mdir($fd).'/cur/'.$file);
$file=~s/,S=\d+.*//; # the static part
opendir DIR, _name2mdir($fd).'/cur/' or die "Error $!\n";
my @lists = grep { !/^\./ } readdir DIR;
close DIR;
for(@lists) {
my $tmpname = $_;
$tmpname =~ s/,S=\d+.*//;
if($tmpname eq $file) {
if(m#/#) {
s/.*\/([^\/]+)$/$1/; # save the filename
}
return $_;
}
}
""; # not found similar
}
sub _parse_cache {
my $s = $_[0];
my %info = ();
foreach (split(/\n/, $s)) {
my $tk = index($_, '=');
my $len = length $_;
$info{substr($_, -$len, $tk)} = substr($_, $tk+1);
}
\%info;
}
# XXX with pos id resort function, slow ?! has been optimize
# using hash ref and smart tech:(
sub _delete_bmsgs_cache {
my ($dir, @pos) = @_;
my $poshash = _array2hash(@pos);
my $cache = $CFG{path}."/"._name2mdir($dir)."/extmail-curcache.db";
use Ext::DB;
my $db = Ext::DB->new(
file => "Btree:$cache",
flags => "write"
);
my $info = _parse_cache($db->lookup('HEADER'));
my $nums = $info->{NEWCOUNT}+$info->{COUNT};
my %newhash = (); # XXX new copy
my $npos = 0;
foreach(0...$nums-1) {
if(_exist_pos_id($_, $poshash)) {
my $lv = _parse_cache($db->lookup("REC$_"));
$db->delete("REC$_");
if(is_new($lv->{FILENAME})) {
$info->{NEWCOUNT}--;
}else {
$info->{COUNT}--;
}
}else {
$newhash{$npos} = $db->lookup("REC$_");
$npos++;
}
}
undef $db; # destory the object
unlink untaint($cache); # XXX rebuild now
$db = Ext::DB->new(
file => "Btree:$cache",
flags => 'write'
);
my $nheader = sprintf "SAVETIME=%s\nCOUNT=%s\nNEWCOUNT=%s\n".
"SORT=%s\n",time,$info->{COUNT},$info->{NEWCOUNT},
$info->{SORT};
$db->update('HEADER', $nheader);
for(0...$npos) {
$db->insert("REC$_", $newhash{$_});
}
}
# convert an array to hash, for big loop compare using
# XXX
sub _array2hash {
my @a = @_;
my %h = ();
for(@a) {
$h{$_} = 1;
}
\%h;
}
# compare pos id with given parameter
sub _exist_pos_id {
my ($key, $ref) = @_;
if($ref->{$key}) { # exist
delete $ref->{$key};
return 1;
}
0;
}
sub get_sortorder {
my $dir = _name2mdir($_[0]);
my $cache = "$dir/extmail-curcache.db";
use Ext::DB;
my $db = Ext::DB->new(file => "Btree:$cache");
my $header = _parse_cache($db->lookup('HEADER'));
undef $db;
return $header->{SORT};
}
sub rebuild_msgs_cache {
my $dir = _name2mdir($_[0]);
$SORTORDER = $_[1] || 'Dt'; # default to Dt
my $cache = "$dir/extmail-curcache.db";
if(!-e $cache) {
_set_msgs_cache($dir); # build it here
}else {
if(-r $cache) {
my $mtime = (stat $cache)[9];
if(time - $mtime > CACHE_CUR_LIFE or
(stat "$dir/extmail-curcnt")[9] - $mtime >0) {
_set_msgs_cache($dir);
}else {
_rebuild_msgs_cache($dir);
}
}else {
die "Can't read $cache, $!\n";
}
}
1;
}
sub set_msgs_cache {
my $dir = _name2mdir($_[0]);
$SORTORDER = $_[1] || 'Dt'; # XXX see SORTORDER defination
my $cache = "$dir/extmail-curcache.db"; # relative path?
if(!-e $cache) {
_set_msgs_cache($dir);
}else {
if(-r $cache) {
my $mtime = (stat $cache)[9];
if(time - $mtime > CACHE_CUR_LIFE or
(stat "$dir/extmail-curcnt")[9] - $mtime >=1 or
(stat "$dir/cur")[9] - $mtime >=1 or # XXX FIXME if >=0 will
# cause del/mv msgs rebuild
# cache duplicated:(
(stat "$dir/new")[9] - $mtime >=0) {
# mtime of curcnt > cache db, or mtime of cur/new
# maildir > cache db indicate that may be new mail
# or pop3 server delete some messages, bug! but
# this design will cause cache.db update too offen,
# waiting for fix, damn it!
#
# add check_new() here, because if new/ change, means
# that some new mails arrive, we must move them to cur
# then if check_new return 0, means there is no new
# mail, but we need to update curcnt to sync mail info
if(check_new($dir) == 0) {
_check_cache_curcnt($dir);
}
_set_msgs_cache($dir);
}
}else {
die "Can't read $cache, $!\n";
}
}
1;
}
sub _rebuild_msgs_cache {
my $fd = $_[0];
my $cache_file = _name2mdir($fd)."/extmail-curcache.db";
my $i = 0;
use Ext::DB;
my @cache; # ARRAY
my $db = Ext::DB->new(file => "Btree:$cache_file");
my $info = _parse_cache($db->lookup('HEADER'));
my $tmp_cache_file = $cache_file.".tmp"; # XXX
for($i=0;$i<$info->{COUNT}+$info->{NEWCOUNT};$i++) {
# bug fix, newly design cache struct should convert
# to a HASH ref instead of raw data
$cache[$i] = _parse_cache($db->lookup("REC$i"));
}
undef $db; # destory Ext::DB object
$db = Ext::DB->new(
file => "Btree:$tmp_cache_file",
flags => 'write'
);
my $header = sprintf "SAVETIME=%s\nCOUNT=%s\nNEWCOUNT=%s\nSORT=%s\n",
time, $info->{COUNT}, $info->{NEWCOUNT}, $SORTORDER||'Dt';
$db->insert('HEADER', $header);
$i = 0;
my $method = cvt2method($SORTORDER);
foreach(($method? sort $method @cache : @cache)) {
$db->insert("REC$i", sprintf("FILENAME=%s\nFROM=%s\n".
"SUBJECT=%s\nSIZES=%s\nDATE=%s\nDATETIME=%s\nSIZEN=%s\n".
"TIME=%s\nINODE=%s\n",
$_->{FILENAME},
$_->{FROM},
$_->{SUBJECT},
$_->{SIZES},
$_->{DATE},
$_->{DATETIME}, # XXX str2time() ed
$_->{SIZEN},
$_->{TIME},
$_->{INODE})
);
$i++;
}
undef @cache;
undef $db;
rename(untaint($tmp_cache_file), untaint($cache_file));
}
sub _set_msgs_cache {
my $fd = _name2mdir($_[0]);
my $list = get_msgs_list($fd);
my @cache; # XXX ARRAY
my $prefix = $CFG{path}."/$fd/cur";
my ($pos,$seen,$new)=(0,0,0);
foreach(@$list) {
my ($path, $file) = ("$prefix/$_", $_);
my ($size_n, $time, $inode) = (stat "$prefix/$file")[7,9,1];
my $size_s = human_size($size_n); # a convertion :-)
my ($from, $subject, $date);
# a faster method to get header than get_msg_info or
# get_msg_header, but still need to optimize :)
my $hdrs = get_msg_hdr_fast($path, $fd =~ /^\.(Drafts|Sent)$/ ? 1 : 0);
if(is_new($file)) { $new++; }
else { $seen++; }
# The following code eat a lot of CPU when building
# cache for a large Maildir, need to rewrite to reduce
# too much loop / find.. :(
#
# Here i remove decode_words call to reduce overhead, but
# should i ? wait for fix XXX, but in benchmark, 55k emails
# under PIII 1G *2 1G RAM, use about 52s (or 76s without FS
# cache the first time runs) time, is better than using
# decode_words call which used about 57s-58s
($from, $subject, $date) = (
$hdrs->{From},
$hdrs->{Subject},
$hdrs->{Date}
);
$from = (defined $from ? $from : "");
$subject = (defined $subject ? $subject : "");
$date = (defined $date ? $date : $time); # fallback
$cache[$pos] = {
FILENAME => $file,
FROM => $from,
SUBJECT => $subject,
SIZES => $size_s,
DATE => $date,
DATETIME => str2time($date) || datefield2dateserial($date), # XXX
SIZEN => $size_n,
TIME => $time,
INODE => $inode,
};
$pos++;
}
$cache[$pos] = {
SAVETIME => time,
COUNT => $seen,
NEWCOUNT => $new,
SORT => $SORTORDER || 'Dt',
};
_set_msgs_cache_do($CFG{path}."/$fd", \@cache);
}
# XXX XXX XXX
# SORTORDER routine
# Dt => date Date: header, slow
# Ts => file timestamp, the most fast
# Sz => file size, normal speed
# Fr => From header, slow
# Sj => Subject header, slow
# Fs => File status, seen or not
#
# if prepend 'r' to SORTORDER means reverse, eg:
# rDt => reverse Date
# rTs => reverse Timestamp
# XXX by_date* func has different mechanism, in general words:
# latest messages should be place at first, but in code level
# it's contrary
sub by_date {
#str2time($b->{DATE}) <=> str2time($a->{DATE});
$b->{DATETIME} <=> $a->{DATETIME};
}
sub by_date_rev {
#str2time($a->{DATE}) <=> str2time($b->{DATE});
$a->{DATETIME} <=> $b->{DATETIME};
}
sub by_size {
$a->{SIZEN} <=> $b->{SIZEN};
}
sub by_size_rev {
$b->{SIZEN} <=> $a->{SIZEN};
}
sub by_from {
lc ($a->{FROM}) cmp lc ($b->{FROM});
}
sub by_from_rev {
lc ($b->{FROM}) cmp lc ($a->{FROM});
}
sub by_subject {
lc ($a->{SUBJECT}) cmp lc ($b->{SUBJECT});
}
sub by_subject_rev {
lc ($b->{SUBJECT}) cmp lc ($a->{SUBJECT});
}
sub by_status {
my $vara = $a->{FILENAME};
my $varb = $b->{FILENAME};
($vara) = ($vara=~/:2,.*S.*/ ? 1:0);
($varb) = ($varb=~/:2,.*S.*/ ? 1:0);
$vara <=> $varb;
}
sub by_status_rev {
my $vara = $a->{FILENAME};
my $varb = $b->{FILENAME};
($vara) = ($vara=~/:2,.*S.*/ ? 1:0);
($varb) = ($varb=~/:2,.*S.*/ ? 1:0);
$varb <=> $vara;
}
sub by_time {
$b->{TIME} <=> $a->{TIME};
}
sub cvt2method {
my ($type) = shift;
if($type =~/(r*)Dt/) {
return ($1 ? 'by_date_rev':'by_date');
}elsif ($type=~/(r*)Sz/) {
return ($1 ? 'by_size_rev':'by_size');
}elsif ($type=~/(r*)Fr/) {
return ($1 ? 'by_from_rev':'by_from');
}elsif ($type=~/(r*)Sj/) {
return ($1 ? 'by_subject_rev':'by_subject');
}elsif ($type=~/(r*)Fs/) {
return ($1 ? 'by_status_rev':'by_status');
}else {
# default to 'Ts'
return 'by_time'; # by_time => Time stamp
}
}
# END of SORTORDER sub routine
sub _set_msgs_cache_do {
my ($fd, $cache) = @_;
my $cache_file = "$fd/extmail-curcache.db";
if(-w $fd) {
use Ext::DB;
my $db = Ext::DB->new(
file => "Btree:$cache_file",
flags => "write"
);
# XXX XXX XXX do an experimental sorting.. SORT
my $buf = pop @$cache;
$db->insert('HEADER', sprintf("SAVETIME=%s\nCOUNT=%s\n".
"NEWCOUNT=%s\nSORT=%s\n",
$buf->{SAVETIME},
$buf->{COUNT},
$buf->{NEWCOUNT},
$buf->{SORT})
);
my $i = 0;
my $method = cvt2method($SORTORDER); # get sort method
foreach($method ? sort $method @$cache : @$cache) {
$db->insert("REC$i", sprintf("FILENAME=%s\nFROM=%s\n".
"SUBJECT=%s\nSIZES=%s\nDATE=%s\nDATETIME=%s\nSIZEN=%s\n".
"TIME=%s\nINODE=%s\n",
$_->{FILENAME},
$_->{FROM},
$_->{SUBJECT},
$_->{SIZES},
$_->{DATE},
$_->{DATETIME}, # XXX
$_->{SIZEN},
$_->{TIME},
$_->{INODE})
);
$i++;
}
undef @$cache; # cleanup, maybe useful in persistent env
#foreach(keys %$cache) {
# db->insert($_, $cache->{$_});
#}
#$db->sync; # sync to disk?
#$db->close;
}else {
die "Can't write curcache to $fd, $!\n";
}
1;
}
# get_dir_cnt - public func of _get_dir_cnt()
sub get_dir_cnt {
my $dir = _name2mdir($_[0]);
return _get_dir_cnt($dir);
}
# _get_dir_cnt - get a specify dir's new / seen counts
sub _get_dir_cnt {
my $fd_dir = $_[0]; # XXX should be relative path?!
# XXX FIXME old design: call _check_cache_curcnt(), new design
# will only return the cached data instead of update it. the
# update task will leave to check_new() or other func
my ($tsize, $seen, $new) = parse_curcnt($fd_dir);
return {
new => $new,
seen => $seen,
size => $tsize
};
}
sub _get_dir_cnt_do {
my $cur_dir = $CFG{path}."/$_[0]/cur";
my ($tsize, $seen, $new) = (0,0,0);
# XXX not need check_new($_[0]); old XXX
opendir DIR, $cur_dir || die "Can't opendir $cur_dir, $!\n";
my @f = sort {$a cmp $b} grep { !/^\.$/ && !/^\..$/ } readdir DIR;
close DIR;
foreach (@f) {
if(is_new($_)) { $new++ }
else { $seen++ }
if(/S=(\d+)/) {
$tsize = $tsize + $1;
}else {
$tsize = $tsize + (stat "$cur_dir/$_")[7];
}
}
return($tsize, $seen, $new);
}
# API change since 0.24-RC2, only accept folder name,
sub parse_curcnt {
my $folder = shift;
my $cache = untaint($CFG{path}.'/'._name2mdir($folder).'/extmail-curcnt');
if (!-e $cache) {
my ($tsize, $seen, $new) = _get_dir_cnt_do($folder);
open(my $FD, "> $cache") or
die "Can't write to $cache $!\n";
print $FD "$tsize $seen $new\n";
close $FD;
}
_parse_curcnt(untaint($cache));
}
sub _parse_curcnt {
my $file = $_[0];
open(my $FD, "< $file") or die "Can't open $file, $!\n";
local $/="\n";
my $str = <$FD>;
close $FD;
chomp $str;
$str =~ m/^(\d+) (\d+) (\d+)/;
return($1, $2, $3);
}
# public function name for _check_cache_curcnt()
sub check_curcnt {
my $fd_dir = shift;
my ($tsize, $seen, $new) = _check_cache_curcnt($fd_dir);
return {
new => $new,
seen => $seen,
size => $tsize
};
}
sub _check_cache_curcnt {
my ($fd_dir) = _name2mdir($_[0]);
my ($write, $cache) = (0, "$fd_dir/extmail-curcnt");
my ($tsize, $seen, $new) = (0,0,0);
# Setuid programe untaint checks
$cache = untaint($cache);
if(-e $cache) {
# update cache
my $mtime = (stat $cache)[9];
if( time - $mtime > CACHE_CNT_LIFE or
(stat "$fd_dir/cur")[9] - $mtime >=0 or
(stat "$fd_dir/new")[9] - $mtime >=0) {
$write = 1;
}
}else { $write = 1; }
if($write) {
($tsize, $seen, $new) = _get_dir_cnt_do($fd_dir);
open(my $FD, "> $cache") or
die "Can't write to $cache $!\n";
print $FD "$tsize $seen $new\n";
close $FD;
}else {
($tsize, $seen, $new) = parse_curcnt($fd_dir);
}
return($tsize, $seen, $new);
}
sub _set_cache_curcnt {
my ($fd_dir, @info) = @_;
my $cache = _name2mdir($fd_dir).'/extmail-curcnt';
$cache = untaint($cache);
open(my $FD, "> $cache") or die "Can't open $cache, $!\n";
flock($FD, LOCK_EX);
# size seen new newline
print $FD "$info[0] $info[1] $info[2]\n";
flock($FD, LOCK_UN);
close $FD;
1;
}
# check_new - to check new messages in a specify folder
sub check_new {
my $dir = _name2mdir($_[0]);
if(_check_new($dir)) {
my $cache = untaint("$CFG{path}/$dir/extmail-curcnt");
my ($tsize, $seen, $new) = _get_dir_cnt_do($dir);
open(my $FD, "> $cache") or
die "Can't write to $cache $!\n";
print $FD "$tsize $seen $new\n";
close $FD;
return 1;
}
return 0;
}
sub _check_new {
my $dir = $CFG{path}."/$_[0]";
opendir DIR, $dir."/new" || die "Can't opendir $dir/new, $!\n";
my @f = grep {!/^\./} readdir DIR;
close DIR;
return 0 unless(scalar @f>0);
foreach(@f) {
my $has_mime = has_attach("$dir/new/$_");
my $tf = $_.":2," . ($has_mime?'A':""); # flag to a file in cur
rename(untaint("$dir/new/$_"), untaint("$dir/cur/$tf")) or
warn "Can't rename $_\n" if (!-e "$dir/cur/$tf");
}
1;
}
sub has_attach {
my $file = untaint ($_[0]);
open(my $fh, "< $file") || die "Can't open $file, $!\n";
my $hlen = _index($fh, "\n\n", 0)+2; # include the 2 newline
my $header = _substr($fh, 0, $hlen);
my $boundary;
if($header=~/boundary="*([^"\r\n]+)"*/i) {
$boundary = $1;
return 0 unless ($boundary);
} else {
return 0;
}
my $start = $hlen;
my $nstart; # nstart - next start pos
while (($nstart= _index($fh, "--$boundary\n", $start))!=-1) {
my $end = _index($fh, "\n\n", $nstart);
my $head = _substr($fh, $nstart, $end - $nstart);
$start = $end;
if ($head =~ m!(filename|name)=!i) {
return 1;
}
if ($head =~ m!message/rfc822!i) {
return 1;
}
}
0;
}
sub is_new {
my $file = $_[0];
# see maildir info section on http://cr.yp.to/proto/maildir.html
# bug fix here, old code: /2,.*S.*$/, it will fail to match
# must have the : character
if($file=~/:2,.*S.*$/) { # original PRSTDF, we only check S(seen) flag
return 0;
}
return 1;
}
sub is_sys_maildir {
my $dir = $_[0];
my @sysdir = ("Inbox", "Sent", "Drafts", "Trash", "Junk");
for(@sysdir) {
return 1 if($_ eq $dir);
}
0;
}
# set bunch of msgs to delete
sub set_bmsgs_delete {
_set_bmsgs_delete(shift,1,@_);
}
sub _set_bmsgs_delete {
my ($dir, $unlink, @pos) = @_;
my $info = get_bmsgs_cache($dir, @pos);
my ($nsizes, $nseen, $nnew) = (0,0,0);
my %quota = ();
for(keys %$info) {
my $file = $CFG{path}.'/'._name2mdir($dir).'/cur';
$file.= '/'.$info->{$_}->{FILENAME};
if($unlink) { # a flag to unlink
unlink(untaint($file));
$quota{$_} = '-'.$info->{$_}->{SIZEN}.' -1';
}
if(is_new($file)) {
$nnew++;
}else {
$nseen++;
}
$nsizes += $info->{$_}->{SIZEN};
}
# after delete, recalculate curcnt and store
# format: size seen new
my @curcnt = parse_curcnt($dir);
$curcnt[0] -= $nsizes;
$curcnt[1] -= $nseen;
$curcnt[2] -= $nnew;
_set_cache_curcnt($dir, @curcnt);
_delete_bmsgs_cache($dir, @pos);
if($unlink) {
# update maildirsize if we truelly unlink
# update_quota("-$nsizes", '-'.$nseen+$nnew);
update_quota_s(\%quota);
}
}
# set bunch of msgs to move
sub set_bmsgs_move {
my ($srcdir, $distdir, @pos) = @_;
my $mvinfo = get_bmsgs_cache(_name2mdir($srcdir), @pos);
my ($nsizes, $nseen, $nnew) = (0,0,0);
foreach my $c (keys %$mvinfo) {
my $file = $mvinfo->{$c}->{'FILENAME'};
my $src = _name2mdir($srcdir).'/cur/'.$file;
my $dst = _name2mdir($distdir).'/cur/'.$file;
rename (untaint($src), untaint($dst)); # omit error
if(is_new($file)) {
$nnew++;
}else {
$nseen++;
}
$nsizes += $mvinfo->{$c}->{SIZEN};
}
_set_bmsgs_delete($srcdir,0,@pos); # set src dir
# dist directory curcnt cache file
my @curcnt = parse_curcnt($distdir);
$curcnt[0] += $nsizes;
$curcnt[1] += $nseen;
$curcnt[2] += $nnew;
_set_cache_curcnt($distdir, @curcnt);
}
# file flag handler func*
sub set_msg_seen {
my ($dir, $pos) = @_;
my $c = get_bmsgs_cache($dir, $pos); # already parsed
$c = $c->{$pos}; # now the real ref
# _check_cache_curcnt first, then set_status, see below explnation
my ($tsize, $seen, $new) = _check_cache_curcnt($dir);
my $nname = set_status($dir, $c->{FILENAME}, '+S'); # XXX ?
return if($c->{FILENAME} eq $nname); # XXX if the same
$c->{FILENAME}=$nname; # update to new name
my $cc = sprintf "FILENAME=%s\nFROM=%s\n".
"SUBJECT=%s\nSIZES=%s\nDATE=%s\nDATETIME=%s\nSIZEN=%s\n".
"TIME=%s\nINODE=%s\n",
$c->{FILENAME},$c->{FROM},$c->{SUBJECT},$c->{SIZES},
$c->{DATE},$c->{DATETIME},$c->{SIZEN},$c->{TIME},$c->{INODE};
undef $c; $c->{$pos} = $cc;
update_bmsgs_cache($dir, %$c);
# race condition: after set_status, if check_cache_curcnt ocationally
# recheck the curcnt and couting new/seen files, say if original it's
# '1840 2 1', then it turn to be '1840 3 0', if we increase seen then
# the finally result is '1840 4 0', ouch :-( Try to advoid, solution:
#
# move _check_cache_curcnt ahead of set_status!
# my ($tsize, $seen, $new) = _check_cache_curcnt($dir);
if($new>0) {
$new--;
$seen++;
}
my @curcnt=($tsize, $seen, $new);
_set_cache_curcnt($dir, @curcnt);
use Ext::DB;
my $cache_file = $CFG{path}.'/'._name2mdir($dir).'/extmail-curcache.db';
my $db = Ext::DB->new(
file => "Btree:$cache_file",
flags => 'write');
my $info = _parse_cache($db->lookup('HEADER'));
my $nheader = sprintf "SAVETIME=%s\nCOUNT=%s\nNEWCOUNT=%s\n".
"SORT=%s\n",time,$seen,$new,$info->{SORT};
$db->update('HEADER', $nheader);
undef $db;
return 1;
}
sub get_status {
my $file = $_[0];
$file =~ m/2,([A-Z]+)/;
$1;
}
sub set_status {
my ($dir, $srcfile, $flag) = @_;
my $distfile = $srcfile;
$dir = $CFG{path}.'/'._name2mdir($dir).'/cur';
my($op, $F) = ($flag=~/([-+])(.*)/);
# XXX FIXME
if ($distfile !~ /:2,/) {
$distfile .= ':2,';
}
if($op eq '-') {
$distfile=~s/:2,(.*)$F(.*)$/:2,$1$2/g;
}
if($op eq '+') {
if($distfile=~/:2,.*$F.*$/) {
return $srcfile; # skip if flag exist
}
$distfile=$distfile.$F;
}
rename(untaint("$dir/$srcfile"), untaint("$dir/$distfile"))
or die "set_status() fail, $!\n";
$distfile; # return the new file name
}
sub is_subdir {
my $dir = _name2mdir($_[0]);
if(-r "$dir/maildirfolder") {
return 1;
}
0;
}
# validate the given maildir name is secure and valid
sub valid_maildir {
my $dir = shift;
if ($dir =~ m!(\.\./|/\.\.|/|^\.+$)!) {
return 0;
}
$dir = _name2mdir($dir);
$dir = $ENV{MAILDIR}.'/'.$dir if $dir !~ m!^/!;
if(-d $dir) {
return 1;
}
0;
}
# Utils funct*
#
# name2mdir - convert a given folder name, aka 'Inbox' or 'Trash' etc,
# to a dir, which makes sense to low level operation.
sub _name2mdir {
my $name = $_[0];
if(!defined $name or $name eq ""
or $name eq 'Inbox') {
".";
}else {
# bug fix, check name first if it has been name2mdir :)
if($name=~m#^\.#) {
$name;
}else {
".$name";
}
}
}
# function to check whether a given dir is valid or not
sub valid_dirname {
my $dir = $_[0];
$dir =~ s/\s+//g; # remove all space
# ouch, we found invalid directory name,
# contains / or .. as prefix
if ($dir =~ m!(/|^\.{2,})!) {
return 0;
} else {
return 1;
}
}
sub _touch {
my $file = untaint ($CFG{path}."/$_[0]");
return 1 if(-e $file);
open(my $FD, "> $file") or die "Can't touch $file, $!\n";
close $FD;
1;
}
1;
syntax highlighted by Code2HTML, v. 0.9.1