delay_mail

   1 #! /usr/bin/perl
   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 $
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 delay_mail - Delay mail to a specific time and send it back
  18
  19 =head1 SYNOPSIS
  20
  21  delay_mail [options] < mail_message
  22
  23  Options:
  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
  33
  34 =head1 OPTIONS
  35
  36 =over
  37
  38 =item B<--enqueue>
  39
  40 Enqueue a message which should be sent out later
  41
  42 =item B<--delay>
  43
  44 Length of delay (man at for details of specification)
  45
  46 =item B<--email>
  47
  48 The delay option is actually an email address; apply the following
  49 regex to parse it:
  50
  51     $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
  52     $delay = $1;
  53     $delay =~ s/_/ /g;
  54     $delay =~ s/=/:/g;
  55
  56 Thus, foo-delay-now+5_min@bar.baz becomes now+5 min and
  57 foo-del+00=30=00@bar.baz becomes 00:30:00
  58
  59 =item B<--list>
  60
  61 List entries which are in the queue
  62
  63 =item B<--dequeue>
  64
  65 Delete an entry from the queue
  66
  67 =item B<--mailto>
  68
  69 Who to mail the delayed mail to
  70
  71 =item B<--queue>
  72
  73 The queue directory to use; defaults to ~/.delay_mail_queue
  74
  75 =item B<--process>
  76
  77 Process a specific entry in the queue (this is called by at at the
  78 appropriate time; you shouldn't need call it manually.)
  79
  80 =item B<--debug, -d>
  81
  82 Debug verbosity. (Default 0)
  83
  84 =item B<--help, -h>
  85
  86 Display brief useage information.
  87
  88 =item B<--man, -m>
  89
  90 Display this manual.
  91
  92 =back
  93
  94 =head1 EXAMPLES
  95
  96
  97 =cut
  98
  99
 100 use vars qw($DEBUG);
 101
 102 my %options = (debug           => 0,
 103                help            => 0,
 104                man             => 0,
 105                email           => 0,
 106               );
 107
 108 GetOptions(\%options,'debug|d+','help|h|?','man|m',
 109            'list|l','dequeue=s','process|p=s','enqueue|e',
 110            'delay|D=s','email|E',
 111            'mailto|mail-to|M=s',
 112           );
 113
 114 pod2usage() if $options{help};
 115 pod2usage({verbose=>2}) if $options{man};
 116
 117 $DEBUG = $options{debug};
 118
 119 use List::Util qw(sum);
 120 use MIME::WordDecoder;
 121 use IO::File;
 122 use IO::Dir;
 123
 124 my $ERROR = '';
 125 if (1 < grep {exists $options{$_}} qw(enqueue list process dequeue)) {
 126      $ERROR .= "Exactly one of --enque, --list, --process, or --dequeue must be specified\n";
 127 }
 128 if (not $options{enqueue} and ($options{email} or exists $options{delay})) {
 129      $ERROR .= "Setting email or delay is nonsensical unless enqueuing\n";
 130 }
 131
 132 pod2usage($ERROR) if length $ERROR;
 133
 134 # create queue directory if it doesn't already exist
 135 if (not exists $options{queue}) {
 136      $options{queue} = "$ENV{HOME}/.delay_mail_queue";
 137 }
 138 if (not -d $options{queue}) {
 139      mkdir($options{queue}) or
 140           die "Unable to create queue directory $options{queue}: $!";
 141 }
 142
 143 if (not exists $options{mailto}) {
 144      if (exists $ENV{EMAIL}) {
 145           $options{mailto} = $ENV{EMAIL};
 146      }
 147      elsif (exists $ENV{USER}) {
 148           $options{mailto} = $ENV{USER};
 149      }
 150      else {
 151           $options{mailto} = qx(id -nu);
 152      }
 153 }
 154 $options{mailto} =~ s/\n//g;
 155
 156 if (exists $options{enqueue}) {
 157      # parse delay
 158      my $delay = $options{delay};
 159      $delay =~ s/\n//g;
 160      if ($options{email}) {
 161           $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
 162           $delay = $1;
 163           $delay =~ s/_/ /g;
 164           $delay =~ s/=/:/g;
 165      }
 166      # slurp email
 167      local $/;
 168      my $email = <STDIN>;
 169      # rip subject out of email
 170      # we cheat for now; this isn't correct at all.
 171      my ($subject) = $email =~ /^Subject:\s*(.+)/mi;
 172      $subject = decode_rfc1522($subject);
 173      $subject =~ s/\n//g;
 174      my $time = time;
 175      # create a queue entry
 176      my $queue_fn = $time . $$;
 177      my $q_fh = IO::File->new("$options{queue}/$queue_fn",'w') or
 178           die "Unable to open $options{queue}/$queue_fn for writing";
 179      print {$q_fh} "delay: $delay\n";
 180      print {$q_fh} "time: $time\n";
 181      print {$q_fh} "mailto: $options{mailto}\n";
 182      print {$q_fh} "entry: $queue_fn\n";
 183      print {$q_fh} "subject: $subject\n";
 184      print {$q_fh} "#####\n";
 185      print {$q_fh} $email;
 186      my $at_fh;
 187      my $pid = open($at_fh,'|-','at',$delay) or exit 1;
 188      print {$at_fh} "$0 '--queue' '$options{queue}' '--process' '$queue_fn';\n";
 189      close $at_fh or exit $?;
 190      exit 0;
 191 }
 192 elsif ($options{list}) {
 193      my $dir = IO::Dir->new($options{queue}) or
 194           die "Unable to list contents of $options{queue}: $!";
 195      my $entry;
 196      my @queue;
 197      while (defined($entry = $dir->read)) {
 198           #valid queue entries are entirely numeric
 199           print STDERR "Dealing with $entry\n" if $DEBUG;
 200           last if not defined $entry;
 201           next if $entry !~ /^\d+$/;
 202           # they're also just readable files
 203           next if not -f "$options{queue}/$entry" or not -r "$options{queue}/$entry";
 204           print STDERR "Still dealing with $entry\n" if $DEBUG;
 205           push @queue,parse_queue_entry($entry);
 206      }
 207      for my $q_e (@queue) {
 208           $q_e->{time} ||='';
 209           print "$q_e->{entry}: send $q_e->{subject} to $q_e->{mailto} at $q_e->{delay} ($q_e->{time})\n";
 210      }
 211 }
 212 elsif ($options{dequeue}) {
 213      if (-e "$options{queue}/$options{dequeue}") {
 214           unlink("$options{queue}/$options{dequeue}") or
 215                die "Unable to unlink $options{queue}/$options{dequeue}";
 216      }
 217      else {
 218           print STDERR "$options{queue}/$options{dequeue} doesn't exist\n"
 219      }
 220 }
 221 elsif ($options{process}) {
 222      if (-e "$options{queue}/$options{process}") {
 223           my $q_e = parse_queue_entry($options{process});
 224           if (not defined $q_e) {
 225                die "Unable to parse $options{process}";
 226           }
 227           # munge the message id
 228           my ($message_id) = $q_e->{email} =~ m/^Message-Id:\s*(.+)/mi;
 229           if (not $message_id =~ s/\@/delay$q_e->{entry}@/){
 230                $message_id =~ s/(\w)/delay$q_e->{entry}$1/;
 231           }
 232           $q_e->{email} =~ s/^(Message-Id:\s*)(.+)/$1$message_id/mi;
 233           # send the message
 234           my $sendmail_fh;
 235           open($sendmail_fh,'|-','/usr/sbin/sendmail',$q_e->{mailto}) or
 236                die "Unable to open sendmail to send message";
 237           print {$sendmail_fh} $q_e->{email};
 238           close($sendmail_fh) or
 239                print STDERR "Sendmail failed with $?\n" and
 240                     exit $?;
 241           unlink("$options{queue}/$options{process}");
 242      }
 243      else {
 244           print STDERR "$options{queue}/$options{process} doesn't exist\n"
 245      }
 246 }
 247
 248
 249 sub parse_queue_entry{
 250      my ($entry) = @_;
 251
 252      my $entry_fh = IO::File->new("$options{queue}/$entry",'r') or
 253           return undef;
 254      my $queue_entry = {};
 255      while (<$entry_fh>) {
 256           last if /^#####/;
 257           chomp;
 258           my $line = $_;
 259           my ($key,$value) = split /: /, $line,2;
 260           $queue_entry->{$key} = $value;
 261      }
 262      local $/;
 263      $queue_entry->{email} = <$entry_fh>;
 264      return $queue_entry;
 265 }
 266
 267
 268 # These functions below I've jacked from Debbugs::MIME which I also
 269 # wrote; probably should put them somewhere else eventually.
 270
 271 sub convert_to_utf8 {
 272      my ($data, $charset) = @_;
 273      # raw data just gets returned (that's the charset WordDecorder
 274      # uses when it doesn't know what to do)
 275      return $data if $charset eq 'raw' or is_utf8($data,1);
 276      my $result;
 277      eval {
 278           # this encode/decode madness is to make sure that the data
 279           # really is valid utf8 and that the is_utf8 flag is off.
 280           $result = encode("utf8",decode($charset,$data))
 281      };
 282      if ($@) {
 283           warn "Unable to decode charset; '$charset' and '$data': $@";
 284           return $data;
 285      }
 286      return $result;
 287 }
 288
 289
 290 BEGIN {
 291     # Set up the default RFC1522 decoder, which turns all charsets that
 292     # are supported into the appropriate UTF-8 charset.
 293     MIME::WordDecoder->default(new MIME::WordDecoder(
 294         ['*' => \&convert_to_utf8,
 295         ]));
 296 }
 297
 298 sub decode_rfc1522
 299 {
 300     my ($string) = @_;
 301
 302     # this is craptacular, but leading space is hacked off by unmime.
 303     # Save it.
 304     my $leading_space = '';
 305     $leading_space = $1 if $string =~ s/^(\s+)//;
 306     # unmime calls the default MIME::WordDecoder handler set up at
 307     # initialization time.
 308     return $leading_space . MIME::WordDecoder::unmime($string);
 309 }
 310
 311
 312
 313 __END__
 314
 315