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