2 # delay_mail delays mail and requeus it, and is released
3 # under the terms of the GPL version 2, or any later version, at your
4 # option. See the file README and COPYING for more information.
5 # Copyright 2006 by Don Armstrong <don@donarmstrong.com>.
6 # $Id: perl_script 495 2006-08-10 08:02:01Z don $
17 delay_mail - Delay mail to a specific time and send it back
21 delay_mail [options] < mail_message
24 --enqueue enqueues a message for sending out later
25 --delay length of delay (suitable for passing to at)
26 --email pull delay out from email address
27 --list list emails in queue
28 --queue directory to use as a queue
29 --process sends out a specific message that was enqueued
30 --debug, -d debugging level (Default 0)
31 --help, -h display this help
32 --man, -m display manual
40 Enqueue a message which should be sent out later
44 Length of delay (man at for details of specification)
48 The delay option is actually an email address; apply the following
51 $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
52 $delay = $1; $delay =~ s/_/ /;
54 Thus, foo-delay-now+5_min@bar.baz becomes now+5 min
58 List entries which are in the queue
62 Delete an entry from the queue
66 Who to mail the delayed mail to
70 The queue directory to use; defaults to ~/.delay_mail_queue
74 Process a specific entry in the queue (this is called by at at the
75 appropriate time; you shouldn't need call it manually.)
79 Debug verbosity. (Default 0)
83 Display brief useage information.
99 my %options = (debug => 0,
105 GetOptions(\%options,'debug|d+','help|h|?','man|m',
106 'list|l','dequeue=s','process|p=s','enqueue|e',
107 'delay|D=s','email|E',
108 'mailto|mail-to|M=s',
111 pod2usage() if $options{help};
112 pod2usage({verbose=>2}) if $options{man};
114 $DEBUG = $options{debug};
116 use List::Util qw(sum);
117 use MIME::WordDecoder;
122 if (1 < grep {exists $options{$_}} qw(enqueue list process dequeue)) {
123 $ERROR .= "Exactly one of --enque, --list, --process, or --dequeue must be specified\n";
125 if (not $options{enqueue} and ($options{email} or exists $options{delay})) {
126 $ERROR .= "Setting email or delay is nonsensical unless enqueuing\n";
129 pod2usage($ERROR) if length $ERROR;
131 # create queue directory if it doesn't already exist
132 if (not exists $options{queue}) {
133 $options{queue} = "$ENV{HOME}/.delay_mail_queue";
135 if (not -d $options{queue}) {
136 mkdir($options{queue}) or
137 die "Unable to create queue directory $options{queue}: $!";
140 if (not exists $options{mailto}) {
141 if (exists $ENV{EMAIL}) {
142 $options{mailto} = $ENV{EMAIL};
144 elsif (exists $ENV{USER}) {
145 $options{mailto} = $ENV{USER};
148 $options{mailto} = qx(id -nu);
151 $options{mailto} =~ s/\n//g;
153 if (exists $options{enqueue}) {
155 my $delay = $options{delay};
157 if ($options{email}) {
158 $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
159 $delay = $1; $delay =~ s/_/ /;
164 # rip subject out of email
165 # we cheat for now; this isn't correct at all.
166 my ($subject) = $email =~ /^Subject:\s*(.+)/mi;
167 $subject = decode_rfc1522($subject);
170 # create a queue entry
171 my $queue_fn = $time . $$;
172 my $q_fh = IO::File->new("$options{queue}/$queue_fn",'w') or
173 die "Unable to open $options{queue}/$queue_fn for writing";
174 print {$q_fh} "delay: $delay\n";
175 print {$q_fh} "time: $time\n";
176 print {$q_fh} "mailto: $options{mailto}\n";
177 print {$q_fh} "entry: $queue_fn\n";
178 print {$q_fh} "subject: $subject\n";
179 print {$q_fh} "#####\n";
180 print {$q_fh} $email;
182 my $pid = open($at_fh,'|-','at',$delay) or exit 1;
183 print {$at_fh} "$0 '--queue' '$options{queue}' '--process' '$queue_fn';\n";
184 close $at_fh or exit $?;
187 elsif ($options{list}) {
188 my $dir = IO::Dir->new($options{queue}) or
189 die "Unable to list contents of $options{queue}: $!";
192 while (defined($entry = $dir->read)) {
193 #valid queue entries are entirely numeric
194 print STDERR "Dealing with $entry\n" if $DEBUG;
195 last if not defined $entry;
196 next if $entry !~ /^\d+$/;
197 # they're also just readable files
198 next if not -f "$options{queue}/$entry" or not -r "$options{queue}/$entry";
199 print STDERR "Still dealing with $entry\n" if $DEBUG;
200 push @queue,parse_queue_entry($entry);
202 for my $q_e (@queue) {
204 print "$q_e->{entry}: send $q_e->{subject} to $q_e->{mailto} at $q_e->{delay} ($q_e->{time})\n";
207 elsif ($options{dequeue}) {
208 if (-e "$options{queue}/$options{dequeue}") {
209 unlink("$options{queue}/$options{dequeue}") or
210 die "Unable to unlink $options{queue}/$options{dequeue}";
213 print STDERR "$options{queue}/$options{dequeue} doesn't exist\n"
216 elsif ($options{process}) {
217 if (-e "$options{queue}/$options{process}") {
218 my $q_e = parse_queue_entry($options{process});
219 if (not defined $q_e) {
220 die "Unable to parse $options{process}";
222 # munge the message id
223 my ($message_id) = $q_e->{email} =~ m/^Message-Id:\s*(.+)/;
224 if (not $message_id =~ s/\@/delay$q_e->{entry}@/){
225 $message_id =~ s/(\w)/delay$q_e->{entry}$1/;
227 $q_e->{email} =~ s/^(Message-Id:\s*)(.+)/$1$message_id/;
230 open($sendmail_fh,'|-','/usr/sbin/sendmail',$q_e->{mailto}) or
231 die "Unable to open sendmail to send message";
232 print {$sendmail_fh} $q_e->{email};
236 print STDERR "Sendmail failed with $?\n";
239 unlink("$options{queue}/$options{process}");
242 print STDERR "$options{queue}/$options{process} doesn't exist\n"
247 sub parse_queue_entry{
250 my $entry_fh = IO::File->new("$options{queue}/$entry",'r') or
252 my $queue_entry = {};
253 while (<$entry_fh>) {
257 my ($key,$value) = split /: /, $line,2;
258 $queue_entry->{$key} = $value;
261 $queue_entry->{email} = <$entry_fh>;
266 # These functions below I've jacked from Debbugs::MIME which I also
267 # wrote; probably should put them somewhere else eventually.
269 sub convert_to_utf8 {
270 my ($data, $charset) = @_;
271 # raw data just gets returned (that's the charset WordDecorder
272 # uses when it doesn't know what to do)
273 return $data if $charset eq 'raw' or is_utf8($data,1);
276 # this encode/decode madness is to make sure that the data
277 # really is valid utf8 and that the is_utf8 flag is off.
278 $result = encode("utf8",decode($charset,$data))
281 warn "Unable to decode charset; '$charset' and '$data': $@";
289 # Set up the default RFC1522 decoder, which turns all charsets that
290 # are supported into the appropriate UTF-8 charset.
291 MIME::WordDecoder->default(new MIME::WordDecoder(
292 ['*' => \&convert_to_utf8,
300 # this is craptacular, but leading space is hacked off by unmime.
302 my $leading_space = '';
303 $leading_space = $1 if $string =~ s/^(\s+)//;
304 # unmime calls the default MIME::WordDecoder handler set up at
305 # initialization time.
306 return $leading_space . MIME::WordDecoder::unmime($string);