3 usage: ../fyvzl [OPTIONS DATABASE-FILE ACTION ARG
5 -l<minrandlength> (for create/choose, number of letters)
9 -C (show comments in output)
12 our $usage2 = <<'END';
14 create [GENOPTS] [REDIRECT] [#COMMENT] (default for REDIRECT is username)
15 choose [GENOPTS] [REDIRECT] [#COMMENT] (generate and interactively allocate)
16 update ADDR [REDIRECT] [#COMMENT]
20 empty string for REDIRECT means reject
22 our $usage3 = <<'END';
25 insert-exact ADDR USER REDIRECT COMMENT
27 enable-user|disable-user USER
36 our $minrandlength = 6;
38 our $maxrandlength = 50;
40 our $maxperuser = 10000;
47 our $genmethod = 'alphanum';
50 die "too few arguments\n" unless @ARGV;
52 die "option too late on command line\n" if $v =~ m/^-/;
56 sub addr2localpart ($) {
58 return $addr if $addr !~ m/\@/;
59 die "address not in correct domain (\@$dom)\n" unless $' eq $dom; #';
64 return addr2localpart nextarg;
68 die "too many arguments\n" if @ARGV;
74 $dis_q ||= $dbh->prepare("SELECT * FROM disabled_users WHERE user=?");
76 my $row = $dis_q->fetchrow_arrayref();
83 if (!defined $last_u or $last_u ne $u) {
84 print "# user $u ".(isdisabled($u) ? 'disabled' : 'enabled')."\n";
91 my $u = $row->{'user'};
93 my $pa = $row->{'localpart'};
94 $pa .= '@'.$dom if defined $dom;
95 if (length $row->{'redirect'}) {
96 print "$pa: $row->{'redirect'}" or die $!;
98 print "# reject $pa" or die $!;
100 if ($showcomment || !$priv) {
101 print " #$row->{'comment'}" or die $!;
103 print "\n" or die $!;
110 read(R, $ch, 1) == 1 or die $!;
113 next unless $o-$v+$lim < 256;
114 # print STDERR "goodrand($lim)=$v\n";
121 if (defined $$ref && $$ref =~ m/[^\041-\177]/) {
122 die "bad characters in redirection target\n";
124 if (defined $$ref && length $$ref && $$ref !~ m/\@/) {
125 die "unqualified redirection target\n" unless defined $qualdom;
126 $$ref .= '@'.$qualdom;
133 "INSERT INTO addrs (".
134 (join ",", sort keys %$row).
136 (join ",", map { "?" } sort keys %$row).
138 $dbh->do($stmt, {}, map { $row->{$_} } sort keys %$row);
146 my $f = (s/^\#// ? 'comment' : 'redirect');
147 die "$f supplied twice\n" if exists $row->{$f};
150 foreach my $f (keys %$defrow) {
151 next if defined $row->{$f};
152 $row->{$f} = $defrow->{$f};
154 qualify $row->{'redirect'};
158 sub local_part_inuse ($) {
160 our $checkexist_q ||=
161 $dbh->prepare("SELECT localpart FROM addrs WHERE localpart=?");
162 $checkexist_q->execute($s);
163 my $row = $checkexist_q->fetchrow_arrayref();
167 sub gen_local_part_alphanum {
168 my $s = chr(ord('a')+goodrand(26));
169 while (length $s < $randlength) {
170 my $v = goodrand(36);
178 sub generate_local_part () {
181 { no strict qw(refs); $s = &{"gen_local_part_$genmethod"}; }
182 # print STDERR "$s\n";
183 last if !local_part_inuse($s);
188 sub prepare_create () {
189 my $countq = $dbh->prepare("SELECT count(*) FROM addrs WHERE user=?");
190 $countq->execute($user);
191 my ($count) = $countq->fetchrow_array();
192 die unless defined $count;
193 die "too many aliases for this user\n" if $count >= $maxperuser;
194 open R, "/dev/urandom" or die $!;
198 sub genopt_alphanum {
202 die "length out of range $minrandlength..$maxrandlength\n"
203 unless ($minrandlength<=$randlength &&
204 $randlength<=$maxrandlength);
206 die "unknown alphanumeric generation option\n";
210 sub gendefaults_alphanum {
211 $randlength ||= $minrandlength;
215 while (@ARGV && $ARGV[0] =~ m/^-/) {
216 my $arg = shift @ARGV;
217 last if $arg =~ m/^--?$/;
218 { no strict qw(refs); &{"genopt_$genmethod"}($arg); }
220 { no strict qw(refs); &{"gendefaults_$genmethod"}(); }
225 my $newrow = rhsargs({'redirect'=>$user, 'comment'=>''});
227 $newrow->{'user'} = $user;
228 $newrow->{'localpart'} = generate_local_part();
236 my $template = rhsargs({'redirect'=>$user, 'comment'=>''});
237 $template->{'user'} = $user;
241 while (keys %s < 10) {
242 my $s = generate_local_part();
245 print "\@$dom" or die $! if $dom;
246 print "\n" or die $!;
249 print "# ready - enter addrs or local-parts to create,".
250 " then \`.' on a line by itself\n"
258 $s = addr2localpart $_;
259 $s{$s} or die "not an (as-yet-unused) suggestion\n";
261 die "just taken in the meantime (bad luck!)\n"
262 if local_part_inuse $s;
265 my $newrow = { %$template, 'localpart' => $s };
270 print "! error: $@" or die $!;
276 my ($localpart) = @_;
277 our $row_q ||= $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
278 $row_q->execute($localpart);
279 return $row_q->fetchrow_hashref();
283 my ($localpart) = @_;
284 my $q = $dbh->prepare("SELECT * FROM addrs WHERE localpart=?");
285 my $row = selectrow $localpart;
286 die "unknown localpart\n" unless defined $row;
287 die "not owned by you\n" unless $priv || $row->{user} eq $user;
292 my $localpart = nextarg_addr;
293 my $updrow = rhsargs({});
295 begin_row($localpart);
296 foreach my $f (qw(redirect comment)) {
297 my $v = $updrow->{$f};
298 next unless defined $v;
299 $dbh->do("UPDATE addrs SET $f=? WHERE localpart=?",
302 my $row = selectrow $localpart;
308 my $localpart = nextarg_addr;
310 my $row = begin_row($localpart);
316 while (my $row = $q->fetchrow_hashref()) {
323 my $q = $dbh->prepare("SELECT * FROM addrs WHERE user=?".
324 " ORDER BY localpart");
329 sub action_list_user {
336 sub action_list_all {
339 my $q = $dbh->prepare("SELECT * FROM addrs".
340 " ORDER BY user, localpart");
345 sub action_insert_exact {
348 $row->{'localpart'} = nextarg_addr;
349 $row->{'user'} = $user = nextarg;
350 $row->{'redirect'} = nextarg;
351 $row->{'comment'} = nextarg;
359 my $localpart = nextarg_addr;
360 my $newuser = nextarg;
362 begin_row($localpart);
363 $dbh->do('UPDATE addrs SET user=? WHERE localpart=?',
364 {}, $newuser, $localpart);
368 sub action_enable_user {
372 $dbh->do('DELETE FROM disabled_users WHERE user=?',{},$user);
376 sub action_disable_user {
380 $dbh->do('INSERT INTO disabled_users VALUES user (?)',{},$user);
384 sub action_list_actions {
385 print $usage2 or die $!;
389 last unless $ARGV[0] =~ m/^-/;
396 } elsif (s/^-m(\d+)$//) {
398 } elsif (s/^-d(\S+)$//) {
400 } elsif (s/^-q(\S+)$//) {
405 print $usage1.$usage2.$usage3 or die $!;
408 die "unknown option \`$_'\n";
413 my $dbfile = nextarg();
415 if (defined $ENV{'USERV_USER'}) {
417 $user = $ENV{'USERV_USER'};
420 $user = ((getpwuid $<)[0]) or die;
423 $usage2 .= defined $dom
424 ? "ADDR may be a local part, implicitly qualified with \@$dom\n"
425 : "ADDR must be a local part (only)\n";
426 $usage2 .= "REDIRECT is implicitly qualified with \@$qualdom if it has no \@\n"
429 $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","",
430 { PrintError => 0, AutoCommit => 0, RaiseError => 1 })
433 my $action = nextarg();
435 { no strict qw(refs); &{"action_$action"}(); }