First pass at adding key files
This commit is contained in:
dsainty
282
site/slowtwitch.com/cgi-bin/articles/admin/GT/Maildir.pm
Normal file
282
site/slowtwitch.com/cgi-bin/articles/admin/GT/Maildir.pm
Normal file
@ -0,0 +1,282 @@
|
||||
package GT::Maildir;
|
||||
|
||||
use vars qw/$error $ERRORS @EXPORT @EXPORT_OK %EXPORT_TAGS/;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base 'GT::Base';
|
||||
|
||||
sub ST_DEV() { 0 }
|
||||
sub ST_INO() { 1 }
|
||||
sub ST_MODE() { 2 }
|
||||
sub ST_NLINK() { 3 }
|
||||
sub ST_UID() { 4 }
|
||||
sub ST_GID() { 5 }
|
||||
sub ST_RDEV() { 6 }
|
||||
sub ST_SIZE() { 7 }
|
||||
sub ST_ATIME() { 8 }
|
||||
sub ST_MTIME() { 9 }
|
||||
sub ST_CTIME() { 10 }
|
||||
sub ST_BLKSIZE() { 11 }
|
||||
sub ST_BLOCKS() { 12 }
|
||||
|
||||
sub ST_NEW () { 1 }
|
||||
sub ST_CUR () { 2 }
|
||||
|
||||
eval {
|
||||
require Time::HiRes;
|
||||
Time::HiRes->import;
|
||||
};
|
||||
use Cwd;
|
||||
use Sys::Hostname;
|
||||
use Carp qw/croak/;
|
||||
use Exporter();
|
||||
|
||||
sub MAILDIR_DELIVERY_TIMEOUT() { 60 * 30 } # 30 minutes
|
||||
|
||||
$ERRORS = {
|
||||
CHDIR => 'Could not chdir to %s: %s',
|
||||
MKTMPFILE => 'Race condition creating tmp file for delivery to %s',
|
||||
FILE_MISSING => "Wrote maildir tmp file but now it's gone; Possible file system troubles",
|
||||
LINK => "Failed to link %s to %s: %s",
|
||||
OVERQUOTA => "User is over thier maildir quota",
|
||||
TIMEOUT => "Timed out on maildir delivery"
|
||||
};
|
||||
|
||||
*import = \&Exporter::import;
|
||||
$error = '';
|
||||
|
||||
@EXPORT = ();
|
||||
@EXPORT_OK = qw(
|
||||
ST_NEW
|
||||
ST_CUR
|
||||
st_to_string
|
||||
|
||||
ST_DEV
|
||||
ST_INO
|
||||
ST_MODE
|
||||
ST_NLINK
|
||||
ST_UID
|
||||
ST_GID
|
||||
ST_RDEV
|
||||
ST_SIZE
|
||||
ST_ATIME
|
||||
ST_MTIME
|
||||
ST_CTIME
|
||||
ST_BLKSIZE
|
||||
ST_BLOCKS
|
||||
);
|
||||
%EXPORT_TAGS = (
|
||||
all => [@EXPORT_OK, @EXPORT],
|
||||
stat => [qw/
|
||||
ST_DEV
|
||||
ST_INO
|
||||
ST_MODE
|
||||
ST_NLINK
|
||||
ST_UID
|
||||
ST_GID
|
||||
ST_RDEV
|
||||
ST_SIZE
|
||||
ST_ATIME
|
||||
ST_MTIME
|
||||
ST_CTIME
|
||||
ST_BLKSIZE
|
||||
ST_BLOCKS
|
||||
/],
|
||||
status => [qw(ST_NEW ST_CUR st_to_string)]
|
||||
);
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
|
||||
croak "Invalid arguments to $class->new. Arguments must be key/value pairs" if @_ & 1;
|
||||
my %opts = @_;
|
||||
$opts{ lc $_ } = delete $opts{$_} for keys %opts;
|
||||
|
||||
croak "No Path specified to $class->new" unless exists $opts{path};
|
||||
my $path = delete $opts{path};
|
||||
croak "Invalid maildir path specified to $class->new" unless defined $path and length $path;
|
||||
my $locker = delete $opts{locker};
|
||||
unless ($locker) {
|
||||
require GT::Maildir::Lock::NFSLock;
|
||||
$locker = GT::Maildir::Lock::NFSLock->new;
|
||||
}
|
||||
my $subdir = delete $opts{subdir};
|
||||
my $maildir_subdir = delete $opts{maildirsubdir};
|
||||
|
||||
$self->{_debug} = exists $opts{debug} ? delete $opts{debug} : $GT::Maildir::DEBUG;
|
||||
|
||||
croak "Unknown arguments to $class->new: ", join(", ", keys %opts) if keys %opts;
|
||||
|
||||
$self->{path} = $path;
|
||||
$self->{maildir_subdir} = $maildir_subdir || 'Maildir';
|
||||
$self->{subdir} = $subdir || 'gt';
|
||||
$self->{locker} = $locker;
|
||||
}
|
||||
|
||||
sub st_to_string {
|
||||
my $st = shift;
|
||||
return $st == ST_NEW ? "new" : "cur";
|
||||
}
|
||||
|
||||
sub make_maildir_root {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->make_maildir: ", join(", ", @_) if @_;
|
||||
my $path = $self->get_maildir_path;
|
||||
my $config_path = $self->get_config_path;
|
||||
$self->get_locker->ex_lock($path, 60*5, 60*20);
|
||||
unless (-d $path) {
|
||||
unlink $path;
|
||||
mkdir $path, 0700 or return $self->error("MKDIR", "WARN", $path, "$!");
|
||||
}
|
||||
for (qw(cur new tmp)) {
|
||||
unless (-d "$path/$_") {
|
||||
unlink "$path/$_";
|
||||
mkdir "$path/$_", 0700 or return $self->error("MKDIR", "WARN", "$path/$_", "$!");
|
||||
}
|
||||
}
|
||||
unless (-d $config_path) {
|
||||
unlink $config_path;
|
||||
mkdir $config_path, 0700 or return $self->error("MKDIR", "WARN", $path, "$!");
|
||||
}
|
||||
$self->get_locker->unlock($path);
|
||||
return 1;
|
||||
}
|
||||
|
||||
my $Maildir_Message_Number = 0;
|
||||
sub deliver_message {
|
||||
my $self = shift;
|
||||
my $folder = shift;
|
||||
my $folder_name = UNIVERSAL::isa($folder, "GT::Maildir::Folder")
|
||||
? $folder->get_name
|
||||
: $folder;
|
||||
croak "Invalid folder $folder_name"
|
||||
unless !ref($folder_name)
|
||||
and defined $folder_name
|
||||
and length $folder_name;
|
||||
my $mail_thingy = shift;
|
||||
my $mail_writer = UNIVERSAL::isa($mail_thingy, "GT::Mail")
|
||||
? sub { $mail_thingy->write(shift) or die "$GT::Mail::error" }
|
||||
: (!ref($mail_thingy) and -e $mail_thingy)
|
||||
? sub { require GT::File::Tools; GT::File::Tools::copy($mail_thingy, shift) or die "$GT::File::Tools::error" }
|
||||
: undef;
|
||||
croak "Unknown email input $mail_thingy" unless defined $mail_writer;
|
||||
my $quotastr = shift;
|
||||
|
||||
my $flags = join '', map { uc substr($_, 0, 1) } grep { defined and /^[DFRST]/i } @_;
|
||||
|
||||
my $path = $self->get_maildir_path;
|
||||
my $folder_path = "$path/$folder_name";
|
||||
my $cwd = getcwd || cwd || die "Could not get cwd";
|
||||
unless (ref $mail_thingy) {
|
||||
if ($mail_thingy !~ m{^/}) {
|
||||
$mail_thingy = "$cwd/$mail_thingy";
|
||||
}
|
||||
}
|
||||
chdir $folder_path or return $self->error("CHDIR", "WARN", $folder_path, "$!");
|
||||
local $@;
|
||||
eval {
|
||||
local $SIG{__DIE__};
|
||||
alarm 0;
|
||||
};
|
||||
my $can_alarm = $@ ? 0 : 1;
|
||||
local $SIG{ALRM} = sub { die "TIMEOUT\n" };
|
||||
my $pid = $$;
|
||||
my $host = hostname;
|
||||
$Maildir_Message_Number++;
|
||||
|
||||
my $tmpfile;
|
||||
for (my $i = 0; ; $i++) {
|
||||
my $t = time;
|
||||
$tmpfile = "tmp/$t.$pid.$Maildir_Message_Number.$host";
|
||||
if (!stat($tmpfile) and $! == 2) { # ENOENT
|
||||
last;
|
||||
}
|
||||
if ($i == 2) {
|
||||
return $self->error("MKTMPFILE", "WARN", "$folder_path/$tmpfile");
|
||||
}
|
||||
sleep 2;
|
||||
}
|
||||
if ($can_alarm) {
|
||||
alarm(MAILDIR_DELIVERY_TIMEOUT);
|
||||
}
|
||||
my $newfile;
|
||||
eval {
|
||||
$mail_writer->($tmpfile);
|
||||
undef $mail_thingy;
|
||||
undef $mail_writer;
|
||||
my @st = stat $tmpfile;
|
||||
die "FILE_MISSING\n" unless @st;
|
||||
if ($st[ST_SIZE] != 0 and $quotastr and $quotastr ne "NOQUOTA") {
|
||||
require GT::Maildir::Quota;
|
||||
my $q = GT::Maildir::Quota->open(".", $quotastr) or die "$GT::Maildir::Quota::error\n";
|
||||
if (!$q->test($st[ST_SIZE], 1)) {
|
||||
die "$GT::Maildir::Quota::error\n" if $GT::Maildir::Quota::error;
|
||||
die "OVERQUOTA\n";
|
||||
}
|
||||
$q->add($st[ST_SIZE], 1);
|
||||
$q->close();
|
||||
}
|
||||
my $new_tmp = "$tmpfile,S=$st[ST_SIZE]:2,$flags";
|
||||
if (!rename($tmpfile, $new_tmp)) {
|
||||
$self->error("RENAME", "FATAL", $tmpfile, $new_tmp, "$!");
|
||||
}
|
||||
$newfile = $new_tmp;
|
||||
$newfile =~ s/tmp/new/;
|
||||
|
||||
if (!link($new_tmp, $newfile)) {
|
||||
$self->error("LINK", "FATAL", $new_tmp, $newfile, "$!");
|
||||
}
|
||||
unlink $new_tmp;
|
||||
};
|
||||
if ($can_alarm) {
|
||||
alarm 0;
|
||||
}
|
||||
if ($@) {
|
||||
my $err = $@;
|
||||
$err =~ s/\n//g;
|
||||
chdir $cwd;
|
||||
return $self->error($err, "WARN");
|
||||
}
|
||||
chdir $cwd;
|
||||
return $newfile;
|
||||
}
|
||||
|
||||
sub get_locker {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_locker: ", join(", ", @_) if @_;
|
||||
return $self->{locker};
|
||||
}
|
||||
|
||||
sub get_path {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_path: ", join(", ", @_) if @_;
|
||||
return $self->{path};
|
||||
}
|
||||
|
||||
sub get_subdir {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_subdir: ", join(", ", @_) if @_;
|
||||
return $self->{subdir};
|
||||
}
|
||||
|
||||
sub get_maildir_subdir {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_maildir_subdir: ", join(", ", @_) if @_;
|
||||
return $self->{maildir_subdir};
|
||||
}
|
||||
|
||||
sub get_maildir_path {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_subdir: ", join(", ", @_) if @_;
|
||||
return $self->{path} . "/" . $self->{maildir_subdir};
|
||||
}
|
||||
|
||||
sub get_config_path {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_subdir: ", join(", ", @_) if @_;
|
||||
return $self->{path} . "/" . $self->{subdir};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
Reference in New Issue
Block a user