--- /dev/null
+#! /usr/bin/perl
+# delay_mail delays mail and requeus it, and is released
+# under the terms of the GPL version 2, or any later version, at your
+# option. See the file README and COPYING for more information.
+# Copyright 2006 by Don Armstrong <don@donarmstrong.com>.
+# $Id: perl_script 495 2006-08-10 08:02:01Z don $
+
+
+use warnings;
+use strict;
+
+use Getopt::Long;
+use Pod::Usage;
+
+=head1 NAME
+
+delay_mail - Delay mail to a specific time and send it back
+
+=head1 SYNOPSIS
+
+ delay_mail [options] < mail_message
+
+ Options:
+ --enqueue enqueues a message for sending out later
+ --delay length of delay (suitable for passing to at)
+ --email pull delay out from email address
+ --list list emails in queue
+ --queue directory to use as a queue
+ --process sends out a specific message that was enqueued
+ --debug, -d debugging level (Default 0)
+ --help, -h display this help
+ --man, -m display manual
+
+=head1 OPTIONS
+
+=over
+
+=item B<--enqueue>
+
+Enqueue a message which should be sent out later
+
+=item B<--delay>
+
+Length of delay (man at for details of specification)
+
+=item B<--email>
+
+The delay option is actually an email address; apply the following
+regex to parse it:
+
+ $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
+ $delay = $1; $delay =~ s/_/ /;
+
+Thus, foo-delay-now+5_min@bar.baz becomes now+5 min
+
+=item B<--list>
+
+List entries which are in the queue
+
+=item B<--dequeue>
+
+Delete an entry from the queue
+
+=item B<--mailto>
+
+Who to mail the delayed mail to
+
+=item B<--queue>
+
+The queue directory to use; defaults to ~/.delay_mail_queue
+
+=item B<--process>
+
+Process a specific entry in the queue (this is called by at at the
+appropriate time; you shouldn't need call it manually.)
+
+=item B<--debug, -d>
+
+Debug verbosity. (Default 0)
+
+=item B<--help, -h>
+
+Display brief useage information.
+
+=item B<--man, -m>
+
+Display this manual.
+
+=back
+
+=head1 EXAMPLES
+
+
+=cut
+
+
+use vars qw($DEBUG);
+
+my %options = (debug => 0,
+ help => 0,
+ man => 0,
+ email => 0,
+ );
+
+GetOptions(\%options,'debug|d+','help|h|?','man|m',
+ 'list|l','dequeue=s','process|p=s','enqueue|e',
+ 'delay|D=s','email|E',
+ 'mailto|mail-to|M=s',
+ );
+
+pod2usage() if $options{help};
+pod2usage({verbose=>2}) if $options{man};
+
+$DEBUG = $options{debug};
+
+use List::Util qw(sum);
+use MIME::WordDecoder;
+use IO::File;
+use IO::Dir;
+
+my $ERROR = '';
+if (1 < grep {exists $options{$_}} qw(enqueue list process dequeue)) {
+ $ERROR .= "Exactly one of --enque, --list, --process, or --dequeue must be specified\n";
+}
+if (not $options{enqueue} and ($options{email} or exists $options{delay})) {
+ $ERROR .= "Setting email or delay is nonsensical unless enqueuing\n";
+}
+
+pod2usage($ERROR) if length $ERROR;
+
+# create queue directory if it doesn't already exist
+if (not exists $options{queue}) {
+ $options{queue} = "$ENV{HOME}/.delay_mail_queue";
+}
+if (not -d $options{queue}) {
+ mkdir($options{queue}) or
+ die "Unable to create queue directory $options{queue}: $!";
+}
+
+if (not exists $options{mailto}) {
+ if (exists $ENV{EMAIL}) {
+ $options{mailto} = $ENV{EMAIL};
+ }
+ elsif (exists $ENV{USER}) {
+ $options{mailto} = $ENV{USER};
+ }
+ else {
+ $options{mailto} = qx(id -nu);
+ }
+}
+$options{mailto} =~ s/\n//g;
+
+if (exists $options{enqueue}) {
+ # parse delay
+ my $delay = $options{delay};
+ $delay =~ s/\n//g;
+ if ($options{email}) {
+ $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
+ $delay = $1; $delay =~ s/_/ /;
+ }
+ # slurp email
+ local $/;
+ my $email = <STDIN>;
+ # rip subject out of email
+ # we cheat for now; this isn't correct at all.
+ my ($subject) = $email =~ /^Subject:\s+(.+)/;
+ $subject = decode_rfc1522($subject);
+ $subject =~ s/\n//g;
+ # create a queue entry
+ my $queue_fn = time . $$;
+ my $q_fh = IO::File->new("$options{queue}/$queue_fn",'w') or
+ die "Unable to open $options{queue}/$queue_fn for writing";
+ print {$q_fh} "delay: $delay\n";
+ print {$q_fh} "mailto: $options{mailto}\n";
+ print {$q_fh} "entry: $queue_fn\n";
+ print {$q_fh} "subject: $subject\n";
+ print {$q_fh} "#####\n";
+ print {$q_fh} $email;
+ my $at_fh;
+ open($at_fh,'|-','at',$delay) or exit 1;
+ print {$at_fh} "$0 '--queue' '$options{queue}' '--process' '$queue_fn';\n";
+ close $at_fh;
+ waitpid(-1,0);
+ exit $?;
+}
+elsif ($options{list}) {
+ my $dir = IO::Dir->new($options{queue}) or
+ die "Unable to list contents of $options{queue}: $!";
+ my $entry;
+ my @queue;
+ while (defined($entry = $dir->read)) {
+ #valid queue entries are entirely numeric
+ last if not defined $entry;
+ next if $entry !~ /^\d+$/;
+ # they're also just readable files
+ next if not -f $entry or not -r $entry;
+ push @queue,parse_queue_entry($entry);
+ }
+ for my $q_e (@queue) {
+ print "$q_e->{entry}: send $q_e->{subject} to $q_e->{mailto} at $q_e->{delay}\n";
+ }
+}
+elsif ($options{dequeue}) {
+ if (-e "$options{queue}/$options{dequeue}") {
+ unlink("$options{queue}/$options{dequeue}") or
+ die "Unable to unlink $options{queue}/$options{dequeue}";
+ }
+ else {
+ print STDERR "$options{queue}/$options{dequeue} doesn't exist\n"
+ }
+}
+elsif ($options{process}) {
+ my $q_e;
+ if (-e "$options{queue}/$options{process}") {
+ my $q_e = parse_queue_entry($options{process});
+ if (not defined $q_e) {
+ die "Unable to parse $options{process}";
+ }
+ # munge the message id
+ my ($message_id) = $q_e->{email} =~ m/^Message-Id:\s*(.+)/;
+ if (not $message_id =~ s/\@/delay$q_e->{entry}@/){
+ $message_id =~ s/(\w)/delay$q_e->{entry}$1/;
+ }
+ $q_e->{email} =~ s/^(Message-Id:\s*)(.+)/$1$message_id/;
+ # send the message
+ my $sendmail_fh;
+ open($sendmail_fh,'|-','/usr/sbin/sendmail',$q_e->{mailto}) or
+ die "Unable to open sendmail to send message";
+ print {$sendmail_fh} $q_e->{email};
+ close($sendmail_fh);
+ waitpid(-1,0);
+ if ($?) {
+ print STDERR "Sendmail failed with $?\n";
+ exit $?;
+ }
+ unlink("$options{queue}/$options{process}");
+ }
+ else {
+ print STDERR "$options{queue}/$options{process} doesn't exist\n"
+ }
+}
+
+
+sub parse_queue_entry{
+ my ($entry) = @_;
+
+ my $entry_fh = IO::File->new("$options{queue}/$entry",'r') or
+ return undef;
+ my $queue_entry = {};
+ while (<$entry_fh>) {
+ last if /^#####/;
+ chomp;
+ my $line = $_;
+ my ($key,$value) = split /: /, $line,2;
+ $queue_entry->{$key} = $value;
+ }
+ local $/;
+ $queue_entry->{email} = <$entry_fh>;
+ return $queue_entry;
+}
+
+
+# These functions below I've jacked from Debbugs::MIME which I also
+# wrote; probably should put them somewhere else eventually.
+
+sub convert_to_utf8 {
+ my ($data, $charset) = @_;
+ # raw data just gets returned (that's the charset WordDecorder
+ # uses when it doesn't know what to do)
+ return $data if $charset eq 'raw' or is_utf8($data,1);
+ my $result;
+ eval {
+ # this encode/decode madness is to make sure that the data
+ # really is valid utf8 and that the is_utf8 flag is off.
+ $result = encode("utf8",decode($charset,$data))
+ };
+ if ($@) {
+ warn "Unable to decode charset; '$charset' and '$data': $@";
+ return $data;
+ }
+ return $result;
+}
+
+
+BEGIN {
+ # Set up the default RFC1522 decoder, which turns all charsets that
+ # are supported into the appropriate UTF-8 charset.
+ MIME::WordDecoder->default(new MIME::WordDecoder(
+ ['*' => \&convert_to_utf8,
+ ]));
+}
+
+sub decode_rfc1522
+{
+ my ($string) = @_;
+
+ # this is craptacular, but leading space is hacked off by unmime.
+ # Save it.
+ my $leading_space = '';
+ $leading_space = $1 if $string =~ s/^(\s+)//;
+ # unmime calls the default MIME::WordDecoder handler set up at
+ # initialization time.
+ return $leading_space . MIME::WordDecoder::unmime($string);
+}
+
+
+
+__END__
+
+
projects / bin.git / commitdiff