3 usage: ../fyvzl [<options>] <database-file> <action> <arg>...
8 -C (show comments in output)
10 options for alphanum generation
11 -l<minrandlength> (for create/choose alphanum, minimum randlength)
13 our $usage2 = <<'END';
15 create [<genopts>] [<redirect>] [#<comment>] (default redirect is username)
16 choose [<genopts>] [<redirect>] [#<comment>] (interactively allocate)
17 update <addr> [<redirect>] [#<comment>]
21 empty string for redirect means reject
23 our $usage3 = <<'END';
26 insert-exact <addr> <user> <redirect> <comment>
28 enable-user|disable-user <user>
29 default generation method is alphanum
31 our %usage_genopts = (
33 -l<randlength> (number of letters+digits)
43 our $maxperuser = 10000;
50 our $genmethod = 'alphanum';
54 our $minrandlength = 6;
55 our $maxrandlength = 100;
60 die "too few arguments\n" unless @ARGV;
62 die "option too late on command line\n" if $v =~ m/^-/;
66 sub addr2localpart ($) {
68 return $addr if $addr !~ m/\@/;
69 die "address not in correct domain (\@$dom)\n" unless $' eq $dom; #';
74 return addr2localpart nextarg;
78 die "too many arguments\n" if @ARGV;
84 $dis_q ||= $dbh->prepare("SELECT * FROM disabled_users WHERE user=?");
86 my $row = $dis_q->fetchrow_arrayref();
93 if (!defined $last_u or $last_u ne $u) {
94 print "# user $u ".(isdisabled($u) ? 'disabled' : 'enabled')."\n";
101 my $u = $row->{'user'};
103 my $pa = $row->{'localpart'};
104 $pa .= '@'.$dom if defined $dom;
105 if (length $row->{'redirect'}) {
106 print "$pa: $row->{'redirect'}" or die $!;
108 print "# reject $pa" or die $!;
110 if ($showcomment || !$priv) {
111 print " #$row->{'comment'}" or die $!;
113 print "\n" or die $!;
120 read(R, $ch, 1) == 1 or die $!;
123 next unless $o-$v+$lim < 256;
124 # print STDERR "goodrand($lim)=$v\n";
131 if (defined $$ref && $$ref =~ m/[^\041-\177]/) {
132 die "bad characters in redirection target\n";
134 if (defined $$ref && length $$ref && $$ref !~ m/\@/) {
135 die "unqualified redirection target\n" unless defined $qualdom;
136 $$ref .= '@'.$qualdom;
143 "INSERT INTO addrs (".
144 (join ",", sort keys %$row).
146 (join ",", map { "?" } sort keys %$row).
148 $dbh->do($stmt, {}, map { $row->{$_} } sort keys %$row);
156 my $f = (s/^\#// ? 'comment' : 'redirect');
157 die "$f supplied twice\n" if exists $row->{$f};
160 foreach my $f (keys %$defrow) {
161 next if defined $row->{$f};
162 $row->{$f} = $defrow->{$f};
164 qualify $row->{'redirect'};
168 sub local_part_inuse ($) {
170 our $checkexist_q ||=
171 $dbh->prepare("SELECT localpart FROM addrs WHERE localpart=?");
172 $checkexist_q->execute($s);
173 my $row = $checkexist_q->fetchrow_arrayref();
177 sub gen_local_part_alphanum {
178 my $s = chr(ord('a')+goodrand(26));
179 while (length $s < $randlength) {
180 my $v = goodrand(36);
188 sub generate_local_part () {
191 { no strict qw(refs); $s = &{"gen_local_part_$genmethod"}; }
192 # print STDERR "$s\n";
193 last if !local_part_inuse($s);
198 sub prepare_create () {
199 my $countq = $dbh->prepare("SELECT count(*) FROM addrs WHERE user=?");
200 $countq->execute($user);
201 my ($count) = $countq->fetchrow_array();
202 die unless defined $count;
203 die "too many aliases for this user\n" if $count >= $maxperuser;
204 open R, "/dev/urandom" or die $!;
208 sub genopt_alphanum {
212 die "length out of range $minrandlength..$maxrandlength\n"
213 unless ($minrandlength<=$randlength &&
214 $randlength<=$maxrandlength);
216 die "unknown alphanumeric generation option\n";
220 sub gendefaults_alphanum {
221 $randlength ||= $minrandlength;
225 while (@ARGV && $ARGV[0] =~ m/^-/) {
226 my $arg = shift @ARGV;
227 last if $arg =~ m/^--?$/;
228 { no strict qw(refs); &{"genopt_$genmethod"}($arg); }
230 { no strict qw(refs); &{"gendefaults_$genmethod"}(); }
235 my $newrow = rhsargs({'redirect'=>$user, 'comment'=>''});
237 $newrow->{'user'} = $user;
238 $newrow->{'localpart'} = generate_local_part();
246 my $template = rhsargs({'redirect'=>$user, 'comment'=>''});
247 $template->{'user'} = $user;
251 while (keys %s < 10) {
252 my $s = generate_local_part();
255 print "\@$dom" or die $! if $dom;
256 print "\n" or die $!;
259 print "# ready - enter addrs or local-parts to create,".
260 " then \`.' on a line by itself\n"
268 $s = addr2localpart $_;
269 $s{$s} or die "not an (as-yet-unused) suggestion\n";
271 die "just taken in the meantime (bad luck!)\n"
272 if local_part_inuse $s;
275 my $newrow = { %$template, 'localpart' => $s };
280 print "! error: $@" or die $!;
286 my ($localpart) = @_;
287 our $row_q ||= $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
288 $row_q->execute($localpart);
289 return $row_q->fetchrow_hashref();
293 my ($localpart) = @_;
294 my $q = $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
295 my $row = selectrow $localpart;
296 die "unknown localpart\n" unless defined $row;
297 die "not owned by you\n" unless $priv || $row->{user} eq $user;
302 my $localpart = nextarg_addr;
303 my $updrow = rhsargs({});
305 begin_row($localpart);
306 foreach my $f (qw(redirect comment)) {
307 my $v = $updrow->{$f};
308 next unless defined $v;
309 $dbh->do("UPDATE addrs SET $f=? WHERE localpart=?",
312 my $row = selectrow $localpart;
318 my $localpart = nextarg_addr;
320 my $row = begin_row($localpart);
326 while (my $row = $q->fetchrow_hashref()) {
333 my $q = $dbh->prepare("SELECT * FROM addrs WHERE user=?".
334 " ORDER BY localpart");
339 sub action_list_user {
346 sub action_list_all {
349 my $q = $dbh->prepare("SELECT * FROM addrs".
350 " ORDER BY user, localpart");
355 sub action_insert_exact {
358 $row->{'localpart'} = nextarg_addr;
359 $row->{'user'} = $user = nextarg;
360 $row->{'redirect'} = nextarg;
361 $row->{'comment'} = nextarg;
369 my $localpart = nextarg_addr;
370 my $newuser = nextarg;
372 begin_row($localpart);
373 $dbh->do('UPDATE addrs SET user=? WHERE localpart=?',
374 {}, $newuser, $localpart);
378 sub action_enable_user {
382 $dbh->do('DELETE FROM disabled_users WHERE user=?',{},$user);
386 sub action_disable_user {
390 $dbh->do('INSERT INTO disabled_users VALUES user (?)',{},$user);
394 sub action_list_actions {
395 print $usage2 or die $!;
396 print "genopts\n" or die $!;
397 print $usage_genopts{$genmethod} or die $!;
401 last unless $ARGV[0] =~ m/^-/;
408 } elsif (s/^-m(\d+)$//) {
410 } elsif (s/^-d(\S+)$//) {
412 } elsif (s/^-q(\S+)$//) {
417 print $usage1.$usage2.$usage3 or die $!;
418 foreach my $meth (qw(alphanum)) {
419 print "genopts for $meth generation method\n" or die $!;
420 print $usage_genopts{$meth} or die $!;
424 die "unknown option \`$_'\n";
429 my $dbfile = nextarg();
431 if (defined $ENV{'USERV_USER'}) {
433 $user = $ENV{'USERV_USER'};
436 $user = ((getpwuid $<)[0]) or die;
439 $usage2 .= defined $dom
440 ? "addr may be a local part, implicitly qualified with \@$dom\n"
441 : "addr must be a local part (only)\n";
442 $usage2 .= "redirect is implicitly qualified with \@$qualdom".
446 $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","",
447 { PrintError => 0, AutoCommit => 0, RaiseError => 1 })
450 my $action = nextarg();
452 { no strict qw(refs); &{"action_$action"}(); }