# Copyrights 2001-2007 by Mark Overmeer.
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 1.02.
package Mail::Box::MH;
use vars '$VERSION';
$VERSION = '2.073';
use strict;
use filetest 'access';
use Carp;
use File::Spec ();
use File::Basename 'basename';
use IO::Handle ();
# Since MailBox 2.052, the use of File::Spec is reduced to the minimum,
# because it is too slow. The '/' directory separators do work on
# Windows too.
my $default_folder_dir = exists $ENV{HOME} ? "$ENV{HOME}/.mh" : '.';
sub init($)
{ my ($self, $args) = @_;
$args->{folderdir} ||= $default_folder_dir;
$args->{lock_file} ||= $args->{index_filename};
$self->SUPER::init($args);
my $folderdir = $self->folderdir;
my $directory = $self->directory;
return unless -d $directory;
# About the index
$self->{MBM_keep_index} = $args->{keep_index} || 0;
$self->{MBM_index} = $args->{index};
$self->{MBM_index_type} = $args->{index_type} || 'Mail::Box::MH::Index';
for($args->{index_filename})
{ $self->{MBM_index_filename}
= !defined $_ ? "$directory/.index" # default
: File::Spec->file_name_is_absolute($_) ? $_ # absolute
: "$directory/$_"; # relative
}
# About labels
$self->{MBM_labels} = $args->{labels};
$self->{MBM_labels_type} = $args->{labels_type} || 'Mail::Box::MH::Labels';
for($args->{labels_filename})
{ $self->{MBM_labels_filename}
= !defined $_ ? "$directory/.mh_sequences"
: File::Spec->file_name_is_absolute($_) ? $_ # absolute
: "$directory/$_"; # relative
}
$self;
}
#-------------------------------------------
sub create($@)
{ my ($thingy, $name, %args) = @_;
my $class = ref $thingy || $thingy;
my $folderdir = $args{folderdir} || $default_folder_dir;
my $directory = $class->folderToDirectory($name, $folderdir);
return $class if -d $directory;
if(mkdir $directory, 0700)
{ $class->log(PROGRESS => "Created folder $name.");
return $class;
}
else
{ $class->log(ERROR => "Cannot create MH folder $name: $!");
return;
}
}
#-------------------------------------------
sub foundIn($@)
{ my $class = shift;
my $name = @_ % 2 ? shift : undef;
my %args = @_;
my $folderdir = $args{folderdir} || $default_folder_dir;
my $directory = $class->folderToDirectory($name, $folderdir);
return 0 unless -d $directory;
return 1 if -f "$directory/1";
# More thorough search required in case some numbered messages
# disappeared (lost at fsck or copy?)
return unless opendir DIR, $directory;
foreach (readdir DIR)
{ next unless m/^\d+$/; # Look for filename which is a number.
closedir DIR;
return 1;
}
closedir DIR;
0;
}
#-------------------------------------------
sub type() {'mh'}
#-------------------------------------------
sub listSubFolders(@)
{ my ($class, %args) = @_;
my $dir;
if(ref $class)
{ $dir = $class->directory;
$class = ref $class;
}
else
{ my $folder = $args{folder} || '=';
my $folderdir = $args{folderdir} || $default_folder_dir;
$dir = $class->folderToDirectory($folder, $folderdir);
}
$args{skip_empty} ||= 0;
$args{check} ||= 0;
# Read the directories from the directory, to find all folders
# stored here. Some directories have to be removed because they
# are created by all kinds of programs, but are no folders.
return () unless -d $dir && opendir DIR, $dir;
my @dirs = grep { !/^\d+$|^\./ && -d "$dir/$_" && -r _ }
readdir DIR;
closedir DIR;
# Skip empty folders. If a folder has sub-folders, then it is not
# empty.
if($args{skip_empty})
{ my @not_empty;
foreach my $subdir (@dirs)
{ if(-f "$dir/$subdir/1")
{ # Fast found: the first message of a filled folder.
push @not_empty, $subdir;
next;
}
opendir DIR, "$dir/$subdir" or next;
my @entities = grep !/^\./, readdir DIR;
closedir DIR;
if(grep /^\d+$/, @entities) # message 1 was not there, but
{ push @not_empty, $subdir; # other message-numbers exist.
next;
}
foreach (@entities)
{ next unless -d "$dir/$subdir/$_";
push @not_empty, $subdir;
last;
}
}
@dirs = @not_empty;
}
# Check if the files we want to return are really folders.
@dirs = map { m/(.*)/ && $1 ? $1 : () } @dirs; # untaint
return @dirs unless $args{check};
grep { $class->foundIn("$dir/$_") } @dirs;
}
#-------------------------------------------
sub openSubFolder($)
{ my ($self, $name) = @_;
my $subdir = $self->nameOfSubFolder($name);
unless(-d $subdir || mkdir $subdir, 0755)
{ warn "Cannot create subfolder $name for $self: $!\n";
return;
}
$self->SUPER::openSubFolder($name, @_);
}
#-------------------------------------------
sub topFolderWithMessages() { 1 }
#-------------------------------------------
sub appendMessages(@)
{ my $class = shift;
my %args = @_;
my @messages = exists $args{message} ? $args{message}
: exists $args{messages} ? @{$args{messages}}
: return ();
my $self = $class->new(@_, access => 'r')
or return ();
my $directory= $self->directory;
return unless -d $directory;
my $locker = $self->locker;
unless($locker->lock)
{ $self->log(ERROR => "Cannot append message without lock on $self.");
return;
}
my $msgnr = $self->highestMessageNumber +1;
foreach my $message (@messages)
{ my $filename = "$directory/$msgnr";
$message->create($filename)
or $self->log(ERROR =>
"Unable to write message for $self to $filename: $!\n");
$msgnr++;
}
$self->labels->append(@messages);
$self->index->append(@messages);
$locker->unlock;
$self->close(write => 'NEVER');
@messages;
}
#-------------------------------------------
sub highestMessageNumber()
{ my $self = shift;
return $self->{MBM_highest_msgnr}
if exists $self->{MBM_highest_msgnr};
my $directory = $self->directory;
opendir DIR, $directory or return;
my @messages = sort {$a <=> $b} grep /^\d+$/, readdir DIR;
closedir DIR;
$messages[-1];
}
#-------------------------------------------
sub index()
{ my $self = shift;
return () unless $self->{MBM_keep_index};
return $self->{MBM_index} if defined $self->{MBM_index};
$self->{MBM_index} = $self->{MBM_index_type}->new
( filename => $self->{MBM_index_filename}
, $self->logSettings
)
}
#-------------------------------------------
sub labels()
{ my $self = shift;
return $self->{MBM_labels} if defined $self->{MBM_labels};
$self->{MBM_labels} = $self->{MBM_labels_type}->new
( filename => $self->{MBM_labels_filename}
, $self->logSettings
);
}
#-------------------------------------------
sub readMessageFilenames
{ my ($self, $dirname) = @_;
opendir DIR, $dirname or return;
# list of numerically sorted, untainted filenames.
my @msgnrs
= sort {$a <=> $b}
map { /^(\d+)$/ && -f "$dirname/$1" ? $1 : () }
readdir DIR;
closedir DIR;
@msgnrs;
}
#-------------------------------------------
sub readMessages(@)
{ my ($self, %args) = @_;
my $directory = $self->directory;
return unless -d $directory;
my $locker = $self->locker;
$locker->lock or return;
my @msgnrs = $self->readMessageFilenames($directory);
my $index = $self->{MBM_index};
unless($index)
{ $index = $self->index;
$index->read if $index;
}
my $labels = $self->{MBM_labels};
unless($labels)
{ $labels = $self->labels;
$labels->read if $labels;
}
my $body_type = $args{body_delayed_type};
my $head_type = $args{head_delayed_type};
my @log = $self->logSettings;
foreach my $msgnr (@msgnrs)
{
my $msgfile = "$directory/$msgnr";
my $head;
$head = $index->get($msgfile) if $index;
$head ||= $head_type->new(@log);
my $message = $args{message_type}->new
( head => $head
, filename => $msgfile
, folder => $self
, fix_header => $self->{MB_fix_headers}
);
my $labref = $labels ? $labels->get($msgnr) : ();
$message->label(seen => 1, $labref ? @$labref : ());
$message->storeBody($body_type->new(@log, message => $message));
$self->storeMessage($message);
}
$self->{MBM_highest_msgnr} = $msgnrs[-1];
$self;
}
#-------------------------------------------
sub delete(@)
{ my $self = shift;
$self->SUPER::delete(@_);
my $dir = $self->directory;
return 1 unless opendir DIR, $dir;
IO::Handle::untaint \*DIR;
# directories (subfolders) are not removed, as planned
unlink "$dir/$_" for readdir DIR;
closedir DIR;
rmdir $dir; # fails when there are subdirs (without recurse)
}
#-------------------------------------------
sub writeMessages($)
{ my ($self, $args) = @_;
# Write each message. Two things complicate life:
# 1 - we may have a huge folder, which should not be on disk twice
# 2 - we may have to replace a message, but it is unacceptable
# to remove the original before we are sure that the new version
# is on disk.
my $locker = $self->locker;
$self->log(ERROR => "Cannot write folder $self without lock."), return
unless $locker->lock;
my $renumber = exists $args->{renumber} ? $args->{renumber} : 1;
my $directory = $self->directory;
my @messages = @{$args->{messages}};
my $writer = 0;
foreach my $message (@messages)
{
my $filename = $message->filename;
my $newfile;
if($renumber || !$filename)
{ $newfile = $directory . '/' . ++$writer;
}
else
{ $newfile = $filename;
$writer = basename $filename;
}
$message->create($newfile);
}
# Write the labels- and the index-file.
my $labels = $self->labels;
$labels->write(@messages) if $labels;
my $index = $self->index;
$index->write(@messages) if $index;
$locker->unlock;
# Remove an empty folder. This is done last, because the code before
# in this method will have cleared the contents of the directory.
if(!@messages && $self->{MB_remove_empty})
{ # If something is still in the directory, this will fail, but I
# don't mind.
rmdir $directory;
}
$self;
}
#-------------------------------------------
1;