# -*-perl-*-
#
# Copyright (c) 1996-1998 Kevin Johnson <kjj@pobox.com>.
#
# All rights reserved. This program is free software; you can
# redistribute it and/or modify it under the same terms as Perl
# itself.
#
# $Id: Emaul.pm,v 1.7 1998/04/05 17:21:53 kjj Exp $
require 5.00397;
package Mail::Folder::Emaul;
use strict;
use vars qw($VERSION @ISA);
@ISA = qw(Mail::Folder);
$VERSION = "0.07";
Mail::Folder->register_type('emaul');
=head1 NAME
Mail::Folder::Emaul - An Emaul folder interface for Mail::Folder.
B<WARNING: This code is in alpha release. Expect the interface to
change.>
=head1 SYNOPSIS
C<use Mail::Folder::Emaul;>
=head1 DESCRIPTION
This module provides an interface to the B<emaul> folder mechanism.
It is currently intended to be used as an example of hooking a folder
interface into Mail::Folder.
The folder structure of B<Emaul> is styled after B<mh>. It uses
directories for folders and numerically-named files for the individual
mail messages. The current message for a particular folder is stored
in a file C<.current_msg> in the folder directory.
Folder locking is accomplished through the use of a .lock file in the
folder directory.
If a C<Timeout> option is specified when the object is created, that
value will be used to determine the timeout for attempting to aquire
a folder lock. The default is 10 seconds.
=cut
use Mail::Folder;
use Mail::Internet;
use Mail::Header;
use IO::File;
use DirHandle;
use Sys::Hostname;
use Carp;
=head1 METHODS
=head2 open($folder_name)
Populates the C<Mail::Folder> object with information about the
folder.
=over 2
=item * Call the superclass C<open> method.
=item * Make sure it is a valid mbox folder.
=item * Check to see it it is readonly
=item * Lock the folder if it is not readonly. (This is dubious)
=item * For every message file in the C<$folder_name> directory, add
the message_number to the list of messages in the object.
=item * Load the contents of C<$folder_dir/.current_msg> into
C<$self-E<gt>{Current}>.
=item * Set C<current_message>.
=item * Load message labels.
=item * Unlock the folder if it is not readonly.
=back
=cut
sub open {
my $self = shift;
my $foldername = shift;
return 0 unless $self->SUPER::open($foldername);
is_valid_folder_format($foldername)
or croak "$foldername isn't an emaul folder";
if (($< == 0) || ($> == 0)) { # if we're root we have to check it by hand
$self->set_readonly unless ((stat($foldername))[2] & 0200);
} else {
$self->set_readonly unless (-w $foldername);
}
return 0 unless ($self->is_readonly || $self->_lock_folder);
for my $msg (_get_folder_msgs($foldername)) {
$self->remember_message($msg);
}
$self->current_message(_load_current_msg($foldername));
$self->_load_message_labels;
$self->_unlock_folder unless ($self->is_readonly);
return 1;
}
=head2 sync
Flushes any pending changes out to the original folder.
=over 2
=item * Call the superclass C<sync> method.
=item * Return C<-1> if the folder is readonly.
=item * Return C<-1> if the folder cannot be locked.
=item * Scan the folder directory for message files that were not
present the last time the folder was either C<open>ed or C<sync>ed
and absorb them.
=item * For every pending delete, unlink that file in the folder
directory
=item * Clear out the 'pending delete' list.
=item * Update the C<.current_msg> file and the C<.msg_labels> file if
the C<NotMUA> option is not set.
=item * Return the number of new messages found.
=back
=cut
sub sync {
my $self = shift;
my $current_message = $self->current_message;
my $qty_new_messages = 0;
my $foldername = $self->foldername;
return -1 if ($self->SUPER::sync == -1);
return -1 unless ($self->is_readonly || $self->_lock_folder);
for my $msg (_get_folder_msgs($foldername)) {
unless (defined($self->{Messages}{$msg})) {
$self->remember_message($msg);
$qty_new_messages++;
}
}
unless ($self->is_readonly) {
# we need to diddle current_message if it's pointing to a deleted msg
my $msg = $self->current_message;
while ($msg >= $self->first_message) {
last if (!$self->label_exists($msg, 'deleted'));
$msg = $self->prev_message($msg);
}
$self->current_message($msg);
for my $msg ($self->select_label('deleted')) {
unlink("$foldername/$msg");
$self->forget_message($msg);
}
$self->clear_label('deleted');
}
unless ($self->is_readonly || $self->get_option('NotMUA')) {
_store_current_msg($foldername, $current_message);
$self->_store_message_labels($foldername);
}
$self->_unlock_folder unless ($self->is_readonly);
return $qty_new_messages;
}
=head2 pack
Calls the superclass C<pack> method.
Return C<0> if the folder is readonly.
Return C<0> if the folder cannot be locked.
Renames the message files in the folder so that there are no gaps in
the numbering sequence. It will tweak C<current_message> accordingly.
Old deleted message files (ones that start with C<,>) are also renamed
as necessary.
It will abandon the operation and return C<0> if a C<rename> fails,
otherwise it returns C<1>.
Please note that C<pack> acts on the real folder.
=cut
sub pack {
my $self = shift;
my $newmsg = 0;
my $folder = $self->foldername;
my $current_message = $self->current_message;
return 0 if (!$self->SUPER::pack || $self->is_readonly);
return 0 unless ($self->_lock_folder);
for my $msg (sort { $a <=> $b } $self->message_list) {
$newmsg++;
if ($msg > $newmsg) {
return 0 if (!rename("$folder/$msg", "$folder/$newmsg") ||
(-e "$folder/,$msg" &&
!rename("$folder/,$msg", "$folder/,$newmsg")));
$self->current_message($newmsg) if ($msg == $current_message);
$self->remember_message($newmsg);
$self->cache_header($newmsg, $self->{Messages}{$msg}{Header});
$self->forget_message($msg);
}
}
$self->_unlock_folder;
return 1;
}
=head2 get_message($msg_number)
Calls the superclass C<get_message> method.
Retrieves the given mail message file into a B<Mail::Internet> object
reference and returns the reference.
It will coerce the C<From_> field into a C<Mail-From> field, add the
'C<seen>' label to the message, remove the C<Content-Length> field
if present, and cache the header.
Returns C<undef> on failure.
=cut
sub get_message {
my $self = shift;
my $key = shift;
my $filename = $self->foldername . "/$key";
return undef unless $self->SUPER::get_message($key);
my $fh = new IO::File $filename
or croak "can't open $filename: $!";
my $mref = new Mail::Internet($fh,
Modify => 0,
MailFrom => 'COERCE');
$fh->close;
$mref->delete('Content-Length');
my $href = $mref->head;
$self->cache_header($key, $href);
$self->add_label($key, 'seen');
return $mref;
}
=head2 get_message_file($msg_number)
Calls the superclass C<get_message_file> method.
Retrieves the given mail message file and returns the name of the file.
Returns C<undef> on failure.
=cut
sub get_message_file {
my $self = shift;
my $key = shift;
return undef unless $self->SUPER::get_message_file($key);
return($self->foldername . "/$key");
}
=head2 get_header($msg_number)
Calls the superclass C<get_header> method.
If the particular header has never been retrieved then C<get_header>
loads the header of the given mail message into a member of
C<$self-E<gt>{Messages}{$msg_number}> and returns the object reference
If the header for the given mail message has already been retrieved in
a prior call to C<get_header>, then the cached entry is returned.
The C<Content-Length> field is deleted from the header object it
returns.
=cut
sub get_header {
my $self = shift;
my $key = shift;
my $hdr = $self->SUPER::get_header($key);
return $hdr if defined($hdr);
# return undef unless $self->SUPER::get_header($key);
# return $self->{Messages}{$key}{Header} if ($self->{Messages}{$key}{Header});
my $fh = new IO::File $self->foldername . "/$key" or return undef;
my $href = new Mail::Header($fh,
Modify => 0,
MailFrom => 'COERCE');
$fh->close;
$href->delete('Content-Length');
$self->cache_header($key, $href);
return $href;
}
=head2 append_message($mref)
Calls the superclass C<append_message> method.
Returns C<0> if it cannot lock the folder.
Appends the contents of the mail message contained C<$mref> to
the the folder.
It also caches the header.
Please note that, contrary to other documentation for B<Mail::Folder>,
the Emaul C<append_message> method actually updates the real folder,
rather than queueing it up for a subsequent sync. The C<dup> and
C<refile> methods are also affected. This will be fixed soon.
=cut
sub append_message {
my $self = shift;
my $mref = shift;
my $dup_mref = $mref->dup;
my $msgnum = $self->last_message;
return 0 unless $self->SUPER::append_message($dup_mref);
return 0 unless $self->_lock_folder;
$msgnum++;
$dup_mref->delete('From ');
_write_message($self->foldername, $msgnum, $dup_mref);
$self->_unlock_folder;
$self->remember_message($msgnum);
$self->cache_header($msgnum, $dup_mref->head);
return 1;
}
=head2 update_message($msg_number, $mref)
Calls the superclass C<update_message> method.
It returns C<0> if it cannot lock the folder.
Replaces the message pointed to by C<$msg_number> with the contents of
the C<Mail::Internet> object reference C<$mref>.
Please note that, contrary to other documentation for B<Mail::Folder>,
the Emaul C<update_message> method actually updates the real folder,
rather than queueing it up for a subsequent sync. This will be fixed
soon.
=cut
sub update_message {
my $self = shift;
my $key = shift;
my $mref = shift;
my $dup_mref = $mref->dup;
$dup_mref->delete('From ');
return 0 unless $self->SUPER::update_message($key, $dup_mref);
return 0 unless $self->_lock_folder;
_write_message($self->foldername, $key, $dup_mref);
$self->_unlock_folder;
return 1;
}
=head2 is_valid_folder_format($foldername)
Returns C<0> if the folder is not a directory or looks like a maildir
folder. The current logic allows it to handle MH directories, but
watch out; you should probably set the C<NotMUA> option so the
interface doesn't create it's own little folder droppings like
C<.msg_labels> and such.
=cut
sub is_valid_folder_format {
my $foldername = shift;
return 0 unless (-d $foldername);
return 0 if (-d "$foldername/tmp" &&
-d "$foldername/cur" &&
-d "$foldername/new"); # make sure it isn't a maildir folder
return 1 if (-f "$foldername/.current_msg");
return 1; # NOTE: this is a leap of faith - if there's
# ever an MH interface, this will have to be
# tweaked...
}
=head2 create($foldername)
Returns C<0> if the folder already exists.
Creates a new folder named C<$foldername> with mode C<0700> and then
returns C<1>.
=cut
sub create {
my $self = shift;
my $foldername = shift;
return 0 if (-e $foldername);
mkdir($foldername, 0700) or croak "can't create $foldername: $!";
return 1;
}
###############################################################################
sub _get_folder_msgs {
my $folder_dir = shift;
my $dir = new DirHandle $folder_dir or croak "can't open $folder_dir: $!";
my @files = grep(/^\d+$/, $dir->read);
$dir->close;
return(@files);
}
sub _lock_folder {
my $self = shift;
my $folder = $self->foldername;
my $fh;
my $timeout = $self->get_option('Timeout');
$timeout ||= 10;
my $sleep = 1.0; # maybe this should be configurable
my $lockfile = "$folder/.lock";
my $nfshack = 0;
if ($self->get_option('NFSLock')) {
$nfshack++;
my $host = hostname;
my $time = time;
$lockfile .= ".$time.$$.$host";
}
for my $num (1 .. int($timeout / $sleep)) {
if ($fh = new IO::File $lockfile, O_CREAT|O_EXCL|O_WRONLY, 0644) {
$fh->close;
if ($nfshack) {
# Whhheeeee!!!!!
# In NFS, the O_CREAT|O_EXCL isn't guaranteed to be atomic.
# So we create a temp file that is probably unique in space
# and time ($folder.lock.$time.$pid.$host).
# Then we use link to create the real lock file. Since link
# is atomic across nfs, this works.
# It loses if it's on a filesystem that doesn't do long filenames.
link $lockfile, "$folder/.lock"
or carp "link return: $!\n";
my @statary = stat($lockfile);
unlink $lockfile;
if (!defined(@statary) || $statary[3] != 2) { # failed to link?
goto RETRY;
}
}
return 1;
}
RETRY:
select(undef, undef, undef, $sleep);
}
carp("can't lock $folder folder: $!");
return 0;
}
sub _unlock_folder {
my $self = shift;
my $folder = $self->foldername;
return unlink("$folder/.lock");
}
sub _write_message {
my $folder_dir = shift;
my $key = shift;
my $mref = shift;
rename("$folder_dir/$key", "$folder_dir/,$key") if (-e "$folder_dir/$key");
my $fh = new IO::File "$folder_dir/$key", O_CREAT|O_WRONLY, 0600
or croak "can't create $folder_dir/$key: $!";
$mref->print($fh);
$fh->close;
return 1;
}
sub _load_current_msg {
my $foldername = shift;
my $current_msg = 0;
if (my $fh = new IO::File "$foldername/.current_msg") {
$current_msg = <$fh>;
$fh->close;
chomp($current_msg);
croak "non-numeric content in $foldername/.current_msg"
if ($current_msg !~ /^\d+$/);
}
return $current_msg;
}
sub _store_current_msg {
my $foldername = shift;
my $current_msg = shift;
my $fh = new IO::File ">$foldername/.current_msg"
or croak "can't write $foldername/.current_msg: $!";
$fh->print("$current_msg\n");
$fh->close;
}
sub _store_message_labels {
my $self = shift;
my @alllabels = $self->list_all_labels;
my @labels;
my $folder = $self->foldername;
my $fh;
if (@alllabels) {
unlink("$folder/.msg_labels");
$fh = new IO::File ">$folder/.msg_labels"
or croak "can't create $folder/.msg_labels: $!";
for my $label (@alllabels) {
@labels = $self->select_label($label);
$fh->print("$label: ", _collapse_select_list(@labels), "\n");
}
$fh->close;
}
}
sub _collapse_select_list {
my @list = sort { $a <=> $b } @_;
my @commalist;
my $low = $list[0];
my $high = $low;
for my $item (@list) {
if ($item > ($high + 1)) {
push(@commalist, ($low != $high) ? "$low-$high" : $low);
$low = $item;
}
$high = $item;
}
push(@commalist, ($low != $high) ? "$low-$high" : $low);
return join(',', @commalist);
}
sub _load_message_labels {
my $self = shift;
my %labels;
my ($label, $value);
my ($low, $high);
if (my $fh = new IO::File $self->foldername . "/.msg_labels") {
while (<$fh>) {
chomp;
next if (/^\s*$/);
next if (/^\s*\#/);
($label, $value) = split(/\s*:\s*/, $_, 2);
$labels{$label} = $value;
for my $commachunk (split(',', $value)) {
if ($commachunk =~ /-/) {
($low, $high) = split(/-/, $commachunk, 2);
} else { $low = $high = $commachunk; }
($low <= $high) or croak "bad message spec: $low > $high: $value";
(($low =~ /^\d+$/) && ($high =~ /^\d+$/))
or croak "bad message spec: $value";
for (; $low <= $high; $low++) {
($self->add_label($low, $label))
if (defined($self->{Messages}{$low}));
}
}
}
$fh->close;
}
}
=head1 AUTHOR
Kevin Johnson E<lt>F<kjj@pobox.com>E<gt>
=head1 COPYRIGHT
Copyright (c) 1996-1998 Kevin Johnson <kjj@pobox.com>.
All rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as Perl itself.
=cut
1;
syntax highlighted by Code2HTML, v. 0.9.1