evade-mail-pregen

   1 #!/usr/bin/perl -w
   2 use strict;
   3 use Carp;
   4 our $us = $0; $us =~ s#.*/##;
   5 our $usage = <<'END';
   6 usage:
   7  $us [<opts>] update <number>|<localpart>@[domain] [<reason>] [<comment>]
   8  $us [<opts>] assign <number>|<localpart>@[domain] <comment>
   9  $us [<opts>] list
  10  $us [<opts>] some <count>                     } will generate aliases
  11  $us [<opts>] range <min>-<max>|<min>+<count>  }  as necessary
  12 opts:
  13  -G<generator>           generator/lister program
  14  -N                      do not generate more aliases
  15  -l.., -d.., -F.., -m..  passed to generator
  16 notes:
  17  Always use $us to edit the comment of a pregen alias;
  18   otherwise we may lose track of the next number alias to pregenerate
  19   and reuse numbers.
  20  <comment> must always start with #, and you will need to quote the
  21   whole comment to protect it from your shell
  22 END
  23
  24 sub fail { die "$us: @_\n"; }
  25 sub badusage { fail "bad usage: @_"; }
  26 sub failstdout () { fail "stdout: $!"; }
  27
  28 our $generator;
  29 our $no_generate=0;
  30 our @genopts;
  31
  32 our %by_localpart;
  33 our @by_number;
  34 our $min_number;
  35
  36 our $comment_pattern = '### PREGEN <number>';
  37 our $comment_re;
  38
  39 sub comment_make ($) {
  40     my ($num) = @_;
  41     my $r = $comment_pattern;
  42     ($r =~ s/\<number\>/$num/) == 1 or confess "$r ?";
  43     return $r;
  44 }
  45
  46 sub run_generator {
  47     my @genargs = @_;
  48     open P, "-|", $generator, @genargs or fail "fork $generator: $!";
  49     while (<P>) {
  50         my ($alias,$comment);
  51         if (m/^\# user/) {
  52             next;
  53         } elsif (m/^\# reject (\S+) (\#.*)$/) {
  54             ($alias,$comment) = ($1,$2);
  55         } elsif (m/^\#/) {
  56             next; # future extension
  57         } elsif (m/^([^#: ])\: [^#]* (\#.*)$/) {
  58             ($alias,$comment) = ($1,$2);
  59         } else {
  60             die "generator output $_ ?";
  61         }
  62         my $localpart = $alias;
  63         $localpart =~ s/\@.*//;
  64         my $row = { Alias => $alias, LocalPart => $localpart };
  65         if ($comment =~ m/^$comment_re$/o) {
  66             $row->{Number}= $1;
  67         }
  68         $by_localpart{$row->{LocalPart}} = $row;
  69         if (defined $row->{Number}) {
  70             $by_number[$row->{Number}] = $row;
  71             $min_number = $row->{Number} if
  72                 (!defined $min_number) || $min_number > $row->{Number};
  73         }
  74     }
  75     $?=0; $!=0; close P or fail "$generator $genargs[0] failed ($! $?)\n";
  76 }
  77
  78 sub fetch_list () {
  79     run_generator qw(list);
  80 }
  81
  82 sub perhaps_generate ($) {
  83     my ($num) = @_;
  84     return undef if $no_generate;
  85     my $alias = $by_number[$num];
  86     return $alias if $alias;
  87     return undef unless $num > $#by_number;
  88     run_generator qw(create), (comment_make $num);
  89     $alias = $by_number[$num];
  90     confess "$num ?" unless $alias;
  91     return $alias;
  92 }
  93
  94 sub parse_target {
  95     @ARGV or badusage "missing specification for alias to change";
  96     my $spec = shift @ARGV;
  97     my $target;
  98     if ($spec =~ m/^(\d{1,9})$/) {
  99         $target = $by_number[$spec];
 100         fail "no alias number $target" unless $target;
 101     } elsif ($spec =~ m/^(.*)\@[^\@]*/) {
 102         $target = $by_localpart{$1};
 103         fail "no alias with local part \`$1'" unless $target;
 104         fail "incorrect or unchecked domain: \`$target->{Alias}' != \`$spec'"
 105             unless $spec eq $target->{Alias} ||
 106                    $spec eq $target->{LocalPart}.'@';
 107     } else {
 108         badusage "bad specification for alias to change";
 109     }
 110 }
 111
 112 sub report ($) {
 113     my ($alias) = @_;
 114     confess unless $alias;
 115     print $alias->{Number}, ' ', $alias->{LocalPart}, "\n"
 116         or failstdout;
 117 }
 118
 119 sub action_update {
 120     my $target = parse_target;
 121     @ARGV or badusage "missing update info\n";
 122     if (defined $target->{Number} && $target->{Number} == $#by_number) {
 123         my $wanted = $#by_number + 1;
 124         perhaps_generate $wanted
 125             or print STDERR <<END or fail "stderr: $!"
 126 $us: Losing track of next number ($wanted), due to use of -N;
 127 $us: will start next alias at #0, unless you say (e.g.) "range $wanted".
 128 END
 129     }
 130     exec $generator, qw(update), $target->{Alias}, @ARGV
 131         or fail "exec $generator: $!";
 132 }
 133
 134 sub action_assign {
 135     (@ARGV==2 &&
 136      $ARGV[1] =~ m/^#/) or
 137      badusage "invalid arguments to assign - forgot to quote it properly?";
 138     action_update;
 139 }
 140
 141 sub action_list {
 142     @ARGV==0 or
 143         badusage "invalid arguments to list";
 144     my $num = $min_number;
 145     while ($num <= $#by_number) {
 146         my $alias = $by_number[$num];
 147         report $alias if $alias;
 148     }
 149 }
 150
 151 sub action_some {
 152     (@ARGV==1 &&
 153      $ARGV[0] =~ m/^(\d+)$/s) or
 154      badusage "invalid arguments to some";
 155     my ($count) = $1;
 156     my $num = $min_number;
 157     while ($count > 0) {
 158         my $alias = generate $num;
 159         if ($alias) {
 160             report $alias;
 161             $count--;
 162         } else {
 163             last if $num > $#by_number; # -N
 164             $num++;
 165         }
 166     }
 167 }
 168
 169 sub action_range {
 170     (@ARGV==1 &&
 171      $ARGV[0] =~ m/^(\d+)(?:([-+])(\d+))?$/s) or
 172      badusage "invalid arguments to range";
 173     my ($num,$op,$rarg) = ($1,$2,$3);
 174     my $limit =
 175         $op eq '+' ? $num+$rarg-1 :
 176         $op eq '-' ? $rarg :
 177         confess "$op ??";
 178     for (; $num<=$limit; $num++) {
 179         my $alias = generate $num;
 180         report $alias if $alias;
 181     }
 182 }
 183
 184 for (;;) {
 185     last unless @ARGV;
 186     last unless $ARGV[0] =~ m/^-/;
 187     my $arg = shift @ARGV;
 188     last if $arg =~ m/^--?$/;
 189     while ($arg =~ m/^-./) {
 190         if ($arg =~ s/^-[ldFm]/-/) {
 191             push @genopts, $arg;
 192         } elsif ($arg =~ s/^-G(.*)//) {
 193             $generator = $1;
 194         } elsif ($arg =~ s/^-N/-/) {
 195             $no_generate = 1;
 196         } else {
 197             badusage "unknown option \`$arg'";
 198         }
 199     }
 200 }
 201
 202 if (!defined $generator) {
 203     $generator = $us;
 204     $generator =~ s/-pregen$//
 205         or fail "unable to calculate default generator".
 206             " (want to strip \`-pregen' from our program name, \`$us')";
 207 }
 208
 209 $comment_pattern =~ m/^#/s
 210     or badusage "comment pattern must start with \`#'";
 211 $comment_re = $comment_pattern;
 212 $comment_re =~ s/\W/\\$&/g;
 213 ($comment_re =~ s'\\<number\\>'([1-9]\d{0,8})'g) == 1 #'
 214     or badusage "comment pattern (\`$comment_pattern')".
 215          " must contain \`<number>' exactly once";
 216
 217 @ARGV or badusage "missing action";
 218 my $action = shift @ARGV;
 219
 220 fetch_list();
 221
 222 $action =~ y/-/_/;
 223 my $actionsub;
 224 { no strict qw(refs); $actionsub = \&{"action_$action"}; }
 225 defined $actionsub or badusage "unknown action $action";
 226 $actionsub->();
 227
 228 close STDOUT or failstdout;