summaryrefslogtreecommitdiffstats
path: root/listadmin.pl
diff options
context:
space:
mode:
Diffstat (limited to 'listadmin.pl')
-rwxr-xr-xlistadmin.pl1764
1 files changed, 1764 insertions, 0 deletions
diff --git a/listadmin.pl b/listadmin.pl
new file mode 100755
index 0000000..b85a471
--- /dev/null
+++ b/listadmin.pl
@@ -0,0 +1,1764 @@
+#! /usr/bin/perl -w
+#
+# listadmin - process messages held by Mailman for approval
+# Written 2003 - 2007 by
+# Kjetil Torgrim Homme <kjetilho+listadmin@ifi.uio.no>
+#
+# Thank you, Sam Watkins and Bernie Hoeneisen, for contributions and
+# feedback.
+#
+# Released into public domain.
+
+my $version = "2.40";
+my $maintainer = "kjetilho+listadmin\@ifi.uio.no";
+
+use HTML::TokeParser;
+use LWP::UserAgent;
+# use LWP::Debug qw(+trace);
+use MIME::Base64;
+use MIME::QuotedPrint;
+use Data::Dumper;
+use Term::ReadLine;
+use Getopt::Long;
+use Text::Reform;
+use I18N::Langinfo qw(langinfo CODESET); # appeared in Perl 5.7.2
+use Encode; # appeared in perl 5.7.1
+use strict;
+use English;
+
+my $rc = $ENV{"HOME"}."/.listadmin.ini";
+
+sub usage {
+ my ($exit_val) = @_;
+ print STDERR <<_end_;
+Usage: $0 [-f CONFIGFILE] [-t MINUTES] [{-a|-r} FILE] [-l] [LISTNAME]
+ -f CONFIGFILE Read configuration from CONFIGFILE.
+ (default: $rc)
+ -t MINUTES Stop processing after MINUTES minutes. Decimals are
+ allowed.
+ --mail Turn off "nomail" flag for the specified addresses
+ --nomail Turn on "nomail" flag for the specified addresses
+ -a FILE Add e-mail addresses in FILE to list
+ -r FILE Remove e-mail addresses in FILE to list
+ --add-member ADDRESS
+ Add ADDRESS as member to list
+ --remove-member ADDRESS
+ Remove ADDRESS from member list
+ -l List subscribers
+ LISTNAME Only process lists with name matching LISTNAME.
+
+If options which modify members are used, LISTNAME must match exactly
+one list.
+_end_
+ exit(defined $exit_val ? $exit_val : 64);
+}
+
+my ($opt_help, $opt_version, $opt_f, $opt_t, $opt_a, $opt_r,
+ @opt_add_member, @opt_remove_member, $opt_l);
+my $opt_mail = 1;
+
+GetOptions("help|?" => \$opt_help,
+ "version|V" => \$opt_version,
+ "f=s" => \$opt_f,
+ "t=i" => \$opt_t,
+ "mail!" => \$opt_mail,
+ "a=s" => \$opt_a,
+ "r=s" => \$opt_r,
+ "add-member=s" => \@opt_add_member,
+ "remove-member=s" => \@opt_remove_member,
+ "l" => \$opt_l)
+ or usage();
+
+usage(0) if $opt_help;
+if ($opt_version) {
+ print "listadmin version $version\n";
+ exit(0);
+}
+
+$rc = $opt_f if $opt_f;
+usage() if defined $opt_t && $opt_t !~ /\d/ && $opt_t !~ /^\d*(\.\d*)?$/;
+
+push(@opt_add_member, read_address_file($opt_a, 1)) if defined $opt_a;
+push(@opt_remove_member, read_address_file($opt_r, 1)) if defined $opt_r;
+
+my $will_modify_membership = 0;
+++$will_modify_membership if @opt_add_member;
+++$will_modify_membership if @opt_remove_member;
+
+usage() if $will_modify_membership > 1;
+usage() if defined $opt_l && $will_modify_membership;
+
+my $ua = new LWP::UserAgent("timeout" => 900, "env_proxy" => 1);
+my $time_limit = time + 60 * ($opt_t || 24*60);
+my $term;
+my $term_encoding = langinfo(CODESET());
+
+# the C and POSIX locale in Solaris uses the charset "646", but Perl
+# doesn't support it.
+$term_encoding = "ascii" if $term_encoding eq "646";
+binmode STDOUT, ":encoding($term_encoding)";
+# Turn on autoflush on STDOUT
+$| = 1;
+
+my $config = read_config ($rc);
+unless ($config) {
+ exit (0) unless prompt_for_config ($rc);
+ $config = read_config ($rc);
+}
+
+my @lists = ();
+if (@ARGV) {
+ if (defined $config->{$ARGV[0]}) {
+ push @lists, $ARGV[0];
+ } else {
+ @lists = sort config_order grep { /$ARGV[0]/o } keys %{$config}
+ }
+ if (@lists == 0) {
+ print STDERR "$ARGV[0]: no matching list\n";
+ usage();
+ }
+} else {
+ @lists = sort config_order keys %{$config}
+}
+
+if (@lists > 1 && ($will_modify_membership || defined $opt_l)) {
+ print STDERR "Too many matching lists\n";
+ print Dumper(\@lists);
+ usage();
+}
+
+my $list = $lists[0];
+
+my $subscribe_result;
+if (@opt_add_member) {
+ $subscribe_result = add_subscribers($list, $config->{$list}, $opt_mail,
+ @opt_add_member);
+}
+if (@opt_remove_member) {
+ $subscribe_result = remove_subscribers($list, $config->{$list},
+ @opt_remove_member);
+}
+if (defined $subscribe_result) {
+ for my $addr (keys %{$subscribe_result}) {
+ print STDERR "$addr: $subscribe_result->{$addr}\n";
+ }
+ if (%{$subscribe_result}) {
+ exit(1);
+ } else {
+ print "Ok\n";
+ exit(0);
+ }
+}
+if (defined $opt_l) {
+ my @subscribers = list_subscribers($list, $config->{$list});
+ print join("\n", @subscribers, "");
+ exit(@subscribers == 0);
+}
+
+my ($num, $count, $from, $subject, $reason, $spamscore);
+
+
+for (@lists) {
+ $list = $_;
+ my $user = $config->{$list}{"user"};
+ my $pw = $config->{$list}{"password"} || "";
+
+ if (time > $time_limit) {
+ print "Time's up, skipping the remaining lists\n";
+ last;
+ }
+
+ my $info = {};
+ my $tries = 0;
+ print "fetching data for $list ... ";
+ do {
+ if (-t && ($pw eq "" || $info->{'autherror'})) {
+ print "\n" unless $tries++;
+ $pw = prompt_password("Enter password" .
+ ($user ? " for $user: ": ": "));
+ next if $pw eq "";
+ }
+ $info = get_list($list, $config->{$list}, $pw);
+ if ($info->{'autherror'}) {
+ print "\n" unless $tries++;
+ print STDERR "ERROR: Username or password for $list incorrect\n";
+ }
+ } while (-t && $info->{'autherror'} && $tries < 9);
+
+ if ($info->{'servererror'}) {
+ print "\n";
+ printf STDERR ("ERROR: fetching %s\n", $info->{'url'});
+ printf STDERR ("ERROR: %s -- skipping list\n",
+ $info->{'servererror'});
+ next;
+ } elsif ($info->{'autherror'}) {
+ print "giving up, proceeding to next list\n";
+ next;
+ } elsif (! %{$info}) {
+ print "nothing in queue\n";
+ next;
+ } else {
+ print "\n";
+ }
+ $config->{$list}{"password"} = $pw;
+
+ my %change = ();
+
+ process_subscriptions ($info, $config->{$list}, \%change);
+ $num = undef;
+ restart_approval:
+ approve_messages ($info, $config->{$list}, \%change);
+
+ if ($config->{$list}->{"confirm"}) {
+ if (scalar %change) {
+ redo_confirm:
+ my $c = prompt ("Submit changes? [yes] ");
+ if ($c =~ /^\s*(\?+|h|hj?elp)\s*$/i) {
+ print <<_END_;
+Nothing will be done to the messages in the administrative queue
+unless you answer this question affirmatively. If you answer "no",
+your changes will be discarded and listadmin will proceed to the
+next mailing list. Type "undo" to go back to the current list.
+_END_
+ goto redo_confirm;
+ }
+ if ($c =~ /^\s*(no?|nei|skip)\s*$/i) {
+ print "skipping ...\n";
+ next;
+ } elsif ($c =~ /^\d+$/) {
+ $num = $c - 1;
+ goto restart_approval;
+ } elsif ($c =~ /^u(ndo)?/) {
+ --$num;
+ goto restart_approval;
+ } elsif ($c !~ /^\s*(|ja?|y|yes)\s*$/i) {
+ goto redo_confirm;
+ }
+ }
+ }
+ print "\n";
+
+ commit_changes ($list, $user, $pw, $config->{$list}{"adminurl"},
+ \%change, $info, $config->{$list}{"logfile"});
+}
+
+sub process_subscriptions {
+ my ($info, $config, $change) = @_;
+ my %subscribers = ();
+ my $num = 0;
+ for my $req (keys %{$info}) {
+ if (exists $info->{$req}->{"subscription"}) {
+ $subscribers{$req} = $info->{$req}->{"subscription"};
+ delete $info->{$req};
+ }
+ }
+ my $count = keys (%subscribers);
+ my $def = $config->{"subdefault"};
+ my $prompt = 'Accept/Reject/Skip/Quit';
+ $prompt .= " [" . uc($def) . "]" if $def;
+ $prompt .= " ? ";
+
+ subscr_loop:
+ for my $id (sort keys %subscribers) {
+ last if time > $time_limit;
+ ++$num;
+ print "\n[$num/$count] ========== $list ==========\n";
+ print "From: $subscribers{$id}\n";
+ print " subscription request\n";
+ my $ans;
+ while (1) {
+ $ans = $config->{"subaction"};
+ $ans ||= prompt ($prompt);
+ $ans = "q" unless defined $ans;
+ $ans =~ s/\s+//g;
+ $ans = $def if $ans eq "";
+ $ans = lc ($ans);
+ if ($ans eq "q") {
+ last subscr_loop;
+ } elsif ($ans eq "s") {
+ delete $change->{$id};
+ next subscr_loop;
+ } elsif ($ans eq "a") {
+ $change->{$id} = [ "sa" ];
+ last;
+ } elsif ($ans eq "r") {
+ my $r = prompt ("Why do you reject? [optional] ");
+ unless (defined $r) {
+
+ }
+ $change->{$id} = [ "sr", $r ];
+ last;
+ } else {
+ print STDERR <<"_end_";
+Choose one of the following actions by typing the corresponding letter
+and pressing Return.
+
+ a Accept -- allow the user to join the mailing list
+ r Reject -- notify sender that the request was turned down
+ s Skip -- do not decide now, leave it for later
+ q Quit -- go on to approving messages
+
+_end_
+ }
+ }
+ }
+}
+
+sub approve_messages {
+ my ($info, $config, $change) = @_;
+
+ my $listdef = $config->{"default"};
+ my $spamlevel = $config->{"spamlevel"};
+ my $ns_from = $config->{"not_spam_if_from"};
+ my $ns_subj = $config->{"not_spam_if_subject"};
+ my $dis_from = $config->{"discard_if_from"};
+ my $dis_subj = $config->{"discard_if_subject"};
+ my $dis_reas = $config->{"discard_if_reason"};
+
+ $count = keys (%{$info}) - 1; # subtract 1 for globals
+ my $search_pattern = "";
+ my $dont_skip_forward = 0;
+ if (!defined ($num)) {
+ $num = 0;
+ } else {
+ $dont_skip_forward = 1;
+ }
+ my $tmpl_header = << '_end_';
+
+<<<<<<<<<<<<<<<<<<<< <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+_end_
+ my $tmpl_message = << '_end_';
+From: <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+<<<<<<<< [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[
+Reason: <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Spam? <<<
+_end_
+
+ my $prompt = 'Approve/Reject/Discard/Skip/view Body/Full/jump #/Undo/Help/Quit';
+ my @num_to_id = grep { ! /^global$/ } sort keys %{$info};
+ my @undo_list = ();
+ msgloop:
+ while ($num < $count) {
+ last if time > $time_limit;
+ my $id = $num_to_id[$num++];
+ $from = $info->{$id}{"from"};
+ $subject = $info->{$id}{"subject"} || "";
+ $reason = $info->{$id}{"reason"};
+ $spamscore = $info->{$id}{"spamscore"};
+ {
+ # Get rid of warning from Encode:
+ # "\x{516b}" does not map to iso-8859-1 at listadmin.pl line 261.
+ # when run in non UTF-8 environment.
+ redraw:
+ local $SIG{__WARN__} = sub {};
+ print form({filler => {left => "=", right => "="}},
+ $tmpl_header,
+ "[$num/$count] =", "$list =");
+ print form({interleave => 1},
+ $tmpl_message,
+ $from,
+ "Subject:", $subject, $reason, $spamscore);
+ }
+ while (1) {
+ my $ans;
+ my $match = "";
+ if ($spamlevel && $spamscore >= $spamlevel) {
+ $match = "spam"; $ans = "d";
+ }
+ $ans ||= $config->{"action"};
+ $match = "From" if got_match ($from, $dis_from);
+ $match = "Subject"
+ if $dis_subj && got_match ($subject, $dis_subj);
+ $match = "reason"
+ if $dis_reas && got_match ($reason, $dis_reas);
+ $ans ||= "d" if $match;
+ $ans = undef if (($ns_subj && $subject =~ $ns_subj) ||
+ ($ns_from && $from =~ $ns_from) ||
+ $dont_skip_forward);
+
+ if ($ans && $match) {
+ if ($match eq "spam") {
+ print "Automatically discarded as spam.\n";
+ } else {
+ print "Automatically discarded due to matching $match\n";
+ }
+ $ans = "d";
+ }
+ my $def = $listdef;
+ $def = $change->{$id}->[0]
+ if defined $change->{$id};
+ my $pr = $prompt;
+ $pr .= " [" . uc($def) . "]" if $def;
+ $pr .= " ? ";
+ $ans ||= prompt ($pr);
+ $ans = "q" unless defined $ans;
+ $ans =~ s/^\s+//;
+ $ans =~ s/\s+$//;
+ $ans = $def if $ans eq "" && defined $def;
+ $ans = lc $ans;
+ if ($ans eq "q") {
+ last msgloop;
+ } elsif ($ans eq "s") {
+ # Undo will be a no-op, except it will go back to this message.
+ push(@undo_list, [$num]);
+ delete $change->{$id};
+ $dont_skip_forward = 0;
+ next msgloop;
+ } elsif ($ans =~ /^\d+$/ && $ans > 0 && $ans <= $count) {
+ $num = $ans - 1;
+ $dont_skip_forward = 1;
+ next msgloop;
+ } elsif ($ans eq "a" || $ans eq "d") {
+ # If it is automatically discarded, add it to existing list
+ push(@undo_list, []) unless $match && @undo_list;
+ push(@{$undo_list[$#undo_list]}, $num);
+ $change->{$id} = [ $ans ];
+ $dont_skip_forward = 0;
+ last;
+ } elsif ($ans eq "u") {
+ unless (@undo_list) {
+ print "Nothing to undo.\n";
+ next;
+ }
+ my @trans_list = @{pop(@undo_list)};
+ for my $m (@trans_list) {
+ delete $change->{$num_to_id[$m - 1]};
+ }
+ $num = $trans_list[0] - 1;
+ $dont_skip_forward = 1;
+ next msgloop;
+ } elsif ($ans =~ /^list(\s+|$)/) {
+ my @list = list_subscribers($list, $config);
+ my $member_count = scalar @list;
+ if ($POSTMATCH ne "") {
+ @list = grep { /$POSTMATCH/ } @list;
+ printf("Found %d matching addresses:\n ", scalar @list);
+ } else {
+ print "Mailing list members:\n ";
+ }
+ print join("\n ", @list);
+ print "\n$member_count members in total\n";
+ } elsif ($ans =~ /^(add|nomail)(\s+|$)/) {
+ my $mail = $1 eq "add";
+ my $addr = $POSTMATCH || $from;
+ my $res = add_subscribers($list, $config, $mail, $addr);
+ for my $addr (keys %{$res}) {
+ print "$addr: $res->{$addr}\n";
+ }
+ print "done\n";
+ } elsif ($ans =~ /^rem(\s+|$)/) {
+ my $address = $POSTMATCH;
+ my $c = prompt ("Remove subscriber? (there is no undo!) [no] ");
+ if ($c =~ /^\s*(ja?|y|yes)\s*$/i) {
+ print "removing...\n";
+ my $res = remove_subscribers($list, $config, $address);
+ for my $addr (keys %{$res}) {
+ print "$addr: $res->{$addr}\n";
+ }
+ print "done\n";
+ } else {
+ print "aborted\n";
+ next;
+ }
+ } elsif ($ans =~ m,([/?])(.*),) {
+ my $i = $num - 1;
+ my $direction = 1;
+ my $fencepost = $count - 1;
+ if ($1 eq "?") {
+ $direction = -1;
+ $fencepost = 1;
+ }
+ # If no pattern is specified, reuse previous pattern.
+ $search_pattern = $2 unless $2 eq "";
+ if ($search_pattern eq "") {
+ print "No search pattern specified. Try 'help'\n";
+ next;
+ }
+ while ($i != $fencepost) {
+ $i += $direction;
+ my $id = $num_to_id[$i];
+ my $search_from = $info->{$id}{"from"};
+ my $search_subject = $info->{$id}{"subject"} || "";
+ if ($search_from =~ /$search_pattern/i ||
+ $search_subject =~ /$search_pattern/i) {
+ $num = $i;
+ $dont_skip_forward = 1;
+ next msgloop;
+ }
+ }
+ print "Pattern not found\n"
+ } elsif ($ans eq "r") {
+ redo_reject:
+ my $def_reason = $info->{$id}{"rejreason"};
+ $def_reason = $change->{$id}->[1]
+ if defined $change->{$id} && $change->{$id}->[0] eq "r";
+ my $r = prompt ("Why do you reject? ", $def_reason);
+ if ($r =~ /^\s*$/) {
+ print "aborted\n";
+ next;
+ } elsif ($r =~ /^\s*(\?+|h|help)\s*$/i) {
+ print "The reason entered will be included in the e-mail ".
+ "sent to the submitter.\n";
+ goto redo_reject;
+ }
+
+ push(@undo_list, [ $num ]);
+ $change->{$id} = [ "r", $r ];
+ $dont_skip_forward = 0;
+ last;
+ } elsif ($ans eq "f") {
+ # Since the raw bytes aren't really Unicode, we set
+ # the replacement sequence to be "<?>" unconditionally.
+ print degrade_charset($info->{$id}{"headers"} . "\n\n" .
+ $info->{$id}{"body"}, "questionmark");
+ } elsif ($ans eq "b") {
+ my $head = $info->{$id}{"headers"};
+ my $text = $info->{$id}{"body"};
+ my $mime_headers = "";
+ if ($head =~ m,content-type:\s*text/,i) {
+ $mime_headers = $head;
+ } elsif ($head =~ m,content-type:\s*multipart/,i) {
+ # This is quick and dirty, we look at the first
+ # MIME headers in the body instead. We can't do
+ # proper MIME parsing since the message is
+ # truncated by Mailman.
+ $mime_headers = $text;
+ }
+ if ($mime_headers =~ /content-transfer-encoding:\s+(\S+)/i) {
+ my $cte = $1;
+ if ($cte =~ /quoted-printable/i) {
+ $text = MIME::QuotedPrint::decode($text);
+ } elsif ($cte =~ /base64/i) {
+ # Don't bother with truncated lines.
+ $text =~ s!([A-Za-z0-9/+=]{72,76})!MIME::Base64::decode_base64($1)!ge;
+ }
+ }
+ if ($mime_headers =~ /charset=(\S+)/i) {
+ my $charset = $1;
+ $charset =~ s/;$//;
+ $charset =~ s/^"(.*)"$/$1/;
+ $charset = guess_charset($charset, $text);
+ eval { $text = Encode::decode($charset, $text) };
+ }
+
+ $text = degrade_charset($text, $config->{unprintable});
+ my @lines = split (/\n/, $text, 21);
+ pop @lines;
+ # local $SIG{__WARN__} = sub {}; # see comment elsewhere
+ print join ("\n", @lines), "\n";
+ } elsif ($ans eq "t") {
+ print $info->{$id}{"date"}, "\n";
+ } elsif ($ans eq "url") {
+ print mailman_url($list, $config->{adminurl}), "\n";
+ } elsif ($ans eq ".") {
+ goto redraw;
+ } elsif ($ans eq "") {
+ # nothing.
+ } else {
+ print <<"end";
+Choose one of the following actions by typing the corresponding letter
+and pressing Return.
+
+ a Approve -- the message will be sent to all members of the list
+ r Reject -- notify sender that the message was rejected
+ d Discard -- throw message away, don't notify sender
+ s Skip -- don't decide now, leave it for later
+ b view Body -- display the first 20 lines of the message
+ f view Full -- display the complete message, including headers
+ t view Time -- display the date the message was sent
+ # jump -- jump backward or forward to message number #
+ u Undo -- undo last approve or discard
+ /pattern -- search for next message with matching From or Subject
+ ?pattern -- search for previous message with matching From or Subject
+ . -- redisplay entry
+ add [address] -- add subscription for address (defaults to From)
+ nomail [address] -- add nomail subscription for address (defaults to From)
+ list [pattern] -- list mailing list members matching optional pattern
+ rem address -- remove list member
+ q Quit -- go on to the next list
+
+end
+ print <<"end" if $listdef;
+The default action for this list when you only press Return is '$listdef'
+
+end
+ }
+ }
+ }
+}
+
+sub url_quote_parameter {
+ my $param = shift;
+ $param =~ s/(\W)/sprintf ("%%%02x", ord ($1))/ge;
+ $param;
+}
+
+sub mailman_params {
+ my ($user, $pw) = @_;
+ my %params;
+ $params{"username"} = $user if defined $user;
+ $params{"adminpw"} = $pw if defined $pw;
+ return \%params;
+}
+
+sub uio_adminurl {
+ my ($domain) = @_;
+ return 'https://{domain}/mailman/{domain}/admindb/{list}'
+ if ($domain eq 'lister.ping.uio.no');
+ return 'http://{domain}/mailman/admindb/{list}@{domain}'
+ if ($domain eq "lister.uio.no");
+ return 'http://{subdomain}-lists.uio.no/mailman/admindb/{list}@{domain}'
+ if ($domain =~ /^(\w+\.)?uio\.no$/);
+ return 'http://lists.{domain}/mailman/admindb/{list}@{domain}'
+ if ($domain eq "simula.no");
+ undef;
+}
+
+sub mailman_url {
+ my ($list, $pattern, $params, $action) = @_;
+
+ my ($lp, $domain) = split ('@', $list);
+
+ $pattern ||= uio_adminurl ($domain);
+ $pattern ||= 'http://{domain}/mailman/admindb/{list}';
+
+ my $url = $pattern;
+ my $subdom = $domain;
+ $subdom = $PREMATCH if $subdom =~ /\./;
+ $url =~ s/\{list\}/$lp/g;
+ $url =~ s/\{domain\}/$domain/g;
+ $url =~ s/\{subdomain\}/$subdom/g;
+ if ($action) {
+ $url =~ s,/admindb/,/admin/,;
+ $url .= "/$action";
+ }
+ $url .= "?$params" if $params;
+ return $url;
+}
+
+# Returns a ref to a hash with all the information about pending messages
+sub get_list {
+ my ($list, $config, $pw) = @_;
+
+ my $starttime = time;
+ my $mmver;
+ my ($page, $page_appr, $resp_appr);
+ my $url = mailman_url($list, $config->{"adminurl"});
+ my $resp = $ua->post($url, mailman_params($config->{"user"}, $pw));
+ unless ($resp->is_success) {
+ return {'servererror' => $resp->status_line, 'url' => $url};
+ }
+ $page = $resp->content;
+
+ my $dumpdir = $config->{"dumpdir"};
+ my $dumpfile;
+ if ($dumpdir && $page) {
+ $dumpfile = "$dumpdir/dump-$list.html";
+ if (open (DUMP, ">$dumpfile")) {
+ print DUMP $page;
+ close (DUMP);
+ }
+ }
+
+ if ($page eq "") {
+ if (time - $starttime > 60) {
+ return {servererror => "Mailman server timed out?", url => $url};
+ } else {
+ return {servererror => "Empty page", url => $url};
+ }
+ } elsif ($page =~ get_trans_re("no_such_list")) {
+ return {servererror => "No such list", url => $url}
+ }
+
+ my $parse = HTML::TokeParser->new(\$page) || die;
+ $parse->get_tag ("title") || die;
+ my $title = $parse->get_trimmed_text ("/title") || die;
+
+ if ($title =~ get_trans_re("authentication")) {
+ return {'autherror' => 1};
+ }
+
+ if ($page !~ get_trans_re("pending_req")) {
+ my $msg = "unexpected contents";
+ # Use rand() to protect a little against tmpfile races
+ $dumpfile ||= "/tmp/dump-" . rand() . "-$list.html";
+ if (open(DUMP, ">$dumpfile")) {
+ chmod(0600, $dumpfile);
+ print DUMP $page;
+ close(DUMP);
+ $msg .= ", please send $dumpfile to $maintainer";
+ }
+ return {servererror => $msg, url => $url};
+ }
+
+ my @mailman_mentions = grep {/Mailman/} split (/\n/, $page);
+ for my $mention (reverse @mailman_mentions) {
+ if ($mention =~ /\bv(ersion)?\s(\d+\.\d+)/) {
+ $mmver = $2;
+ last;
+ }
+ }
+ unless ($mmver) {
+ die "Can not find version information, please mail maintainer.";
+ }
+
+ if ($mmver ge "2.1") {
+ # Mailman does not look for "details" in parameters, so it
+ # must be part of the query string.
+ $url = mailman_url($list, $config->{"adminurl"}, "details=all");
+ $resp = $ua->post($url, mailman_params($config->{"user"}, $pw));
+ unless ($resp->is_success) {
+ return {'servererror' => $resp->status_line, 'url' => $url};
+ }
+ $page_appr = $resp->content;
+ if (defined $dumpdir &&
+ open (DUMP, ">$dumpdir/dump-details-$list.html")) {
+ print DUMP $page_appr;
+ close (DUMP);
+ }
+ }
+
+ my $data;
+ if ($mmver eq "2.1") {
+ my $parse_appr = HTML::TokeParser->new(\$page_appr) || die;
+ $data = parse_pages_mm_2_1($mmver, $config, $parse, $parse_appr);
+ } else {
+ $data = parse_pages_mm_old($mmver, $config, $parse);
+ }
+ set_param_values($mmver, $data) if %{$data};
+ return $data;
+}
+
+sub parse_pages_mm_old {
+ my ($mmver, $config, $parse) = @_;
+
+ my %data = ();
+ my $token;
+ $parse->get_tag ("hr");
+ $parse->get_tag ("h2") || return \%data;
+ my $headline = $parse->get_trimmed_text ("/h2") || die;
+ if ($headline =~ get_trans_re("headline_subscr")) {
+ parse_subscriptions ($mmver, $config, $parse, \%data);
+ $token = $parse->get_token;
+ if (lc ($token->[1]) eq "input") {
+ return (\%data);
+ } else {
+ $parse->get_tag ("h2") || die;
+ $headline = $parse->get_trimmed_text ("/h2") || die;
+ }
+ }
+ if ($headline =~ get_trans_re("held_for_approval")) {
+ parse_approvals ($mmver, $config, $parse, \%data);
+ } else {
+ $parse->get_tag ("hr") || die;
+ $token = $parse->get_token;
+ if ($token->[0] eq "S" && lc ($token->[1]) eq "center") {
+ parse_approvals ($mmver, $config, $parse, \%data);
+ }
+ }
+ return (\%data);
+}
+
+sub parse_pages_mm_2_1 {
+ my ($mmver, $config, $parse_subs, $parse_appr) = @_;
+
+ my %data = ();
+ my $headline;
+
+ $parse_subs->get_tag ("hr");
+ if ($parse_subs->get_tag ("h2")) {
+ parse_subscriptions ($mmver, $config, $parse_subs, \%data);
+ }
+
+ $parse_appr->get_tag ("hr");
+ if ($parse_appr->get_tag ("h2")) {
+ parse_approvals ($mmver, $config, $parse_appr, \%data);
+ }
+ return (\%data);
+}
+
+sub parse_subscriptions {
+ my ($mmver, $config, $parse, $data) = @_;
+ my $token;
+
+ $parse->get_tag ("table") || die;
+ $parse->get_tag ("tr") || die;
+ $parse->get_tag ("tr") || die;
+ do {
+ parse_subscription ($mmver, $config, $parse, $data);
+ do {
+ $token = $parse->get_token;
+ } until ($token->[0] eq "S");
+ } while (lc ($token->[1]) eq "tr");
+}
+
+sub parse_subscription {
+ my ($mmver, $config, $parse, $data) = @_;
+
+ $parse->get_tag ("td") || die;
+ my $address = $parse->get_trimmed_text ("/td") || die;
+ my $tag = $parse->get_tag ("input") || die;
+ my $id = $tag->[1]{"name"};
+ $parse->get_tag ("/table") || die;
+ $parse->get_tag ("/tr") || die;
+ $data->{$id} = { "subscription" => $address };
+}
+
+sub parse_approvals {
+ my ($mmver, $config, $parse, $data) = @_;
+ my $token;
+
+ do {
+ $parse->get_tag ("table") || die;
+ parse_approval ($mmver, $config, $parse, $data);
+ $parse->get_tag ("/table");
+ $parse->get_tag ("hr");
+ $token = $parse->get_token;
+ $token = $parse->get_token
+ if ($token->[0] eq "S" && lc ($token->[1]) eq "center");
+ } until ($token->[0] eq "S" && lc ($token->[1]) eq "input");
+}
+
+sub get_trans_re {
+ my ($key) = @_;
+
+ # Handle translations -- poorly...
+ #
+ # For now, we look for strings in all languages at the same time
+ # since they don't seem to overlap. This might have to change
+ # later.
+ #
+ # Please send additions if you have them.
+
+ my %translations =
+ ("authentication" =>
+ {
+ "en" => "authentication",
+ "de" => "Authentifikation",
+ "fr" => "authentification",
+ },
+ "subscr_success" =>
+ {
+ "en" => "Successfully ((un)?subscribed|Removed)",
+ "de" => "Erfolgreich (ein|aus)getragen",
+ },
+ "subscr_error" =>
+ {
+ "en" => "Error (un)?subscribing",
+ },
+ "no_such_list" =>
+ {
+ "en" => "Mailman Admindb Error.*No such list:",
+ },
+ "pending_req" =>
+ {
+ "en" => "(current set of administrative|pending request)",
+ "de" => "(gegenw&auml;rtigen administrativen|unbearbeiteten Anfragen)",
+ },
+ "headline_subscr" =>
+ {
+ "en" => "subscription",
+ },
+ "held_for_approval" =>
+ {
+ "en" => "held for approval",
+ },
+ "already_member" =>
+ {
+ "en" => "Already a member",
+ },
+ );
+
+ my $t = $translations{$key};
+ die "INTERNAL ERROR: Unknown translation key '$key'\n"
+ unless defined $t;
+ return "(?i)(" . join("|", values %{$t}) . ")";
+}
+
+sub guess_charset {
+ my ($charset, $text) = @_;
+
+ # Mislabeling Shift JIS as ISO 2022 is a very common mistake.
+ if ($charset =~ /^iso-2022-jp/i && $text =~ /[\x80-\x9f]/) {
+ return "Shift_JIS";
+ }
+ return $charset;
+}
+
+sub decode_rfc2047_qp {
+ my ($charset, $encoded_word) = @_;
+ my $text = $encoded_word;
+ $text =~ s/_/ /g;
+ $text = MIME::QuotedPrint::decode($text);
+ $charset = guess_charset($charset, $text);
+ eval { $text = Encode::decode($charset, $text) };
+ return defined $text ? $text : $encoded_word;
+}
+
+sub decode_rfc2047_base64 {
+ my ($charset, $encoded_word) = @_;
+ my $text = MIME::QuotedPrint::decode_base64($encoded_word);
+ $charset = guess_charset($charset, $text);
+ eval { $text = Encode::decode($charset, $text) };
+ return defined $text ? $text : $encoded_word;
+}
+
+sub decode_rfc2047 {
+ my ($hdr, $config) = @_;
+
+ # Bugs: Decodes invalid tokens, where the encoded word is
+ # concatenated with other letters, e.g. foo=?utf-8?q?=A0=F8?=
+ # Also decodes base64 encoded words which are doubly encoded with
+ # quoted-printable.
+
+ $hdr =~ s/=\?([^? ]+)\?q\?([^? ]*)\?=/
+ decode_rfc2047_qp($1, $2)/ieg;
+ $hdr =~ s/=\?([^? ]+)\?b\?([^? ]*)\?=/
+ decode_rfc2047_base64($1, $2)/ieg;
+
+ return degrade_charset($hdr, $config->{unprintable});
+}
+
+sub degrade_charset {
+ my ($text, $unprintable) = @_;
+
+ # Handle unencoded Shift JIS (Japanese) text. The input text is
+ # either raw data from the message, or Unicode, in which case it
+ # will not contain these code points. This discrimates slightly
+ # against users of Windows-1252, which has curved quotes at 0x82
+ # (0x81 is unassigned).
+
+ if ($text =~ /[\x81\x82]/) {
+ eval { $text = Encode::decode("Shift_JIS", $text) };
+ }
+
+ # This may look a bit silly. We first encode to the character set
+ # of our terminal. If it is a limited character set such as
+ # Latin1, Chinese glyphs are converted into e.g. "&#x41a;", while
+ # "n with tilde" will be a single glyph. We then convert this
+ # back to a Unicode string so that the length is right (number of
+ # glyphs, not octets) for Text::Reform. Finally, when the Unicode
+ # string is printed to the screen, the binmode directive for
+ # STDOUT tells Perl to once more translate it into the terminal's
+ # character set.
+
+ eval {
+ $text = Encode::decode($term_encoding,
+ Encode::encode($term_encoding, $text,
+ Encode::FB_HTMLCREF))
+ };
+
+ # The built-in formats for unprintable glyphs are ugly, and to be
+ # allowed to specify a code ref which returns our preferred format
+ # directly, we need to require Encode version 2.10, which feels a
+ # bit unnecessary.
+
+ if (defined $config && $unprintable eq "unicode") {
+ $text =~ s/&\#(\d+);/sprintf("<U+%04x>", $1)/ge;
+ } else {
+ $text =~ s/&\#\d+;/<?>/g;
+ }
+
+ # Get rid of ESC sequences which may cause havoc with the
+ # terminal, we only keep TAB and LF. Also removes control
+ # characters with high bit set, 127-159, which are unallocated in
+ # Unicode.
+
+ $text =~ s/([\x00-\x08\x0b-\x1f\x7f-\x9f])/sprintf("<%02x>", ord($1))/eg;
+
+ return $text;
+}
+
+
+sub parse_approval {
+ my ($mmver, $config, $parse, $data) = @_;
+ my ($from, $reason, $subject, $id, $body, $headers);
+
+ $parse->get_tag ("tr") || die; # From:
+ $parse->get_tag ("td") || die;
+ $parse->get_tag ("td") || die;
+ $from = $parse->get_trimmed_text("/td");
+
+ if ($mmver eq "1.2") {
+ $parse->get_tag ("tr") || die; # Reason:
+ $parse->get_tag ("td") || die;
+ $parse->get_tag ("td") || die;
+ $reason = $parse->get_trimmed_text("/td");
+ $parse->get_tag ("tr") || die; # Subject:
+ $parse->get_tag ("td") || die;
+ $parse->get_tag ("td") || die;
+ $subject = $parse->get_trimmed_text("/td");
+ } else {
+ $parse->get_tag ("tr") || die; # Subject:
+ $parse->get_tag ("td") || die;
+ $parse->get_tag ("td") || die;
+ $subject = $parse->get_trimmed_text("/td");
+ $parse->get_tag ("tr") || die; # Reason:
+ $parse->get_tag ("td") || die;
+ $parse->get_tag ("td") || die;
+ $reason = $parse->get_trimmed_text("/td");
+ }
+ $parse->get_tag ("tr") || die; # Action:
+ my $tag = $parse->get_tag ("input") || die;
+ $id = $tag->[1]{"name"};
+
+ $data->{$id} = { "from" => decode_rfc2047($from, $config),
+ "subject" => $subject,
+ "reason" => $reason };
+
+ $parse->get_tag ("tr") || die; # Reject _or_ Preserve message
+ if ($mmver ge "2.0") {
+ $parse->get_tag ("tr") || die; # forward
+ $parse->get_tag ("tr") || die; # Reject
+ }
+ $parse->get_tag ("td") || die;
+ $parse->get_tag ("td") || die;
+ $data->{$id}->{"rejreason"} = $parse->get_trimmed_text("/td") || die;
+
+
+ $parse->get_tag ("tr") || die; # Message Excerpt _or_ Headers
+ $parse->get_tag ("td") || die;
+ $parse->get_tag ("td") || die;
+ $headers = $parse->get_text("/td");
+
+ # We handle spam score headers on the formats:
+ # X-spam-score: *****
+ # X-spam-score: 4.23 (****)
+ #
+ # The name of the header is flexible.
+ my $header_re = $config->{"spamheader"} || 'X-\S*spam-?(?:level|score)';
+
+ # Extract all spam score headers, and pick the max value:
+ my $spamscore = 0;
+ while ($headers =~ /^$header_re:\s+
+ (-?\d+\.\d+\s+)?
+ \(?
+ ((\S)\3*)
+ (?:\s|\)|$)/xgim) {
+ my $score = defined $1 ? int($1): length($2);
+ $spamscore = $score if $score > $spamscore;
+ }
+ $data->{$id}->{"spamscore"} = $spamscore;
+ $data->{$id}->{"date"} = "<no date>";
+ $data->{$id}->{"date"} = $1
+ if $headers =~ /^Date:\s+(.*)$/m;
+ if ($mmver ge "2.0") {
+ $parse->get_tag ("tr") || die; # Message Excerpt
+ $parse->get_tag ("td") || die;
+ $parse->get_tag ("textarea") || die;
+ $body = $parse->get_text("/textarea");
+ } else {
+ $headers =~ s/\n\n//s;
+ $body = $POSTMATCH;
+ $headers = $PREMATCH;
+ }
+ $headers =~ s/\n(\s)/$1/g; # Header folding
+ $headers =~ s/^\s+//;
+ $data->{$id}->{"headers"} = $headers;
+
+ # Mailman decodes Subject itself, but at least version 2.0 and 2.1
+ # screw up non-ASCII characters, so we get the raw value from the
+ # headers instead.
+ if ($headers =~ /^Subject:\s*(.*)\s*$/mi) {
+ $subject = $1;
+ }
+ if ($subject =~ /[\x80-\xff]/) {
+ $subject .= " [unencoded]";
+ }
+
+ $data->{$id}->{"subject"} = decode_rfc2047($subject, $config);
+
+ $body .= "\n" unless $body =~ /\n$/;
+ $data->{$id}->{"body"} = $body;
+
+ return ($mmver);
+}
+
+sub set_param_values {
+ my ($mmver, $data) = @_;
+
+ if ($mmver ge "2.0") {
+ $data->{"global"}{"actions"} = { "a" => 1,
+ "r" => 2,
+ "d" => 3,
+ "sa" => 4, # subscribe approve
+ "sr" => 2, # subscribe reject
+ };
+ } else {
+ $data->{"global"}{"actions"} = { "a" => 0,
+ "r" => 1,
+ "d" => 2,
+ "sa" => 1, # subscribe approve
+ "sr" => 0, # subscribe reject
+ };
+ }
+}
+
+sub read_config {
+ my ($file) = @_;
+
+ my %cur = map { $_ => undef; }
+ qw (not_spam_if_from
+ not_spam_if_subject
+ discard_if_from
+ discard_if_subject
+ discard_if_reason);
+ my $pattern_keywords = join ("|", keys %cur);
+
+ # Defaults:
+ $cur{user} = $cur{password} = $cur{action} = $cur{default} = "";
+ $cur{confirm} = 1;
+ $cur{unprintable} = "questionmark";
+
+ my $conf = {};
+ my $line = "";
+ my $count = 0;
+ my $lineno = 0;
+
+ my %act = ("approve" => "a", "discard" => "d",
+ "reject" => "r", "skip" => "s", "none" => "");
+ my %sact = ("accept" => "a",
+ "reject" => "r", "skip" => "s", "none" => "");
+
+ return undef unless open (CONF, $file);
+ while (<CONF>) {
+ ++$lineno;
+ chomp;
+ s/\r$//;
+ s/\s+$//; # trailing whitespace is "always" unintended
+ next if /^\s*\#/;
+ s/^\s+// if $line; # remove leading whitespace after continuation
+ if (/\\$/) {
+ $line .= $PREMATCH;
+ next;
+ }
+ $line .= $_;
+ $line =~ s/^\s+//;
+ next if /^$/;
+ if ($line =~ /^username\s+/i) {
+ $cur{user} = unquote($POSTMATCH);
+ if ($cur{user} !~ /^[a-z0-9._+-]+\@[a-z0-9.-]+$/) {
+ print STDERR "$file:$lineno: Illegal username: '$cur{user}'\n";
+ exit 1;
+ }
+ } elsif ($line =~ /^password\s+/i) {
+ $cur{password} = unquote($POSTMATCH);
+ } elsif ($line =~ /^spamlevel\s+/i) {
+ $cur{spamlevel} = unquote($POSTMATCH);
+ if ($cur{spamlevel} =~ /^(\d+)\s*$/) {
+ $cur{spamlevel} = $1;
+ } else {
+ print STDERR "$file:$lineno: Illegal value: '$cur{spamlevel}'\n";
+ print STDERR "choose a positive numeric value\n";
+ exit 1;
+ }
+ } elsif ($line =~ /^(confirm|meta_member_support)\s+/i) {
+ my ($key, $value) = (lc($1), unquote($POSTMATCH));
+ if ($value eq "yes") {
+ $value = 1;
+ } elsif ($value eq "no") {
+ $value = undef;
+ } else {
+ print STDERR "$file:$lineno: Illegal value: '$value\n";
+ print STDERR "choose one of yes or no\n";
+ exit 1;
+ }
+ $cur{$key} = $value;
+ } elsif ($line =~ /^(action|default)\s+/i) {
+ my ($key, $value) = (lc($1), unquote($POSTMATCH));
+ unless (exists $act{$value}) {
+ print STDERR "$file:$lineno: Illegal value: '$value\n";
+ print STDERR "choose one of ",
+ join (", ", sort keys %act), "\n";
+ exit 1;
+ }
+ $cur{$key} = $act{$value};
+ } elsif ($line =~ /^adminurl\s+/i) {
+ $cur{adminurl} = unquote($POSTMATCH);
+ $cur{adminurl} = undef if $cur{adminurl} eq "NONE";
+ } elsif ($line =~ /^log\s+/i) {
+ $cur{logfile} = expand_pathname(unquote($POSTMATCH));
+ } elsif ($line =~ /^dumpdir\s+/i) {
+ $cur{dumpdir} = expand_pathname(unquote($POSTMATCH));
+ mkdir($cur{dumpdir}) if (defined $cur{dumpdir});
+ } elsif ($line =~ /^subscription_(action|default)\s+/) {
+ my $key = "sub" . lc($1);
+ my $value = unquote($POSTMATCH);
+ unless (exists $sact{$value}) {
+ print STDERR "$file:$lineno: Illegal value: '$value'\n";
+ print STDERR "choose one of ",
+ join (", ", sort keys %sact), "\n";
+ exit 1;
+ }
+ $cur{$key} = $sact{$value};
+ } elsif ($line =~ /^($pattern_keywords)\s+/o) {
+ my $key = $1;
+ my $val = $POSTMATCH;
+ $val =~ s/\s+$//;
+ if ($val =~ /^"(.*)"$/) {
+ $val = $1;
+ $val =~ s/\\"/"/g;
+ $val =~ s/\\\\/\\/g;
+ }
+ $cur{$key} = ($val eq "NONE") ? undef : $val;
+ } elsif ($line =~ /^spamheader\s+/) {
+ $cur{spamheader} = unquote($POSTMATCH);
+ unless ($cur{spamheader} =~ /^[\w-]+$/) {
+ print STDERR "$file:$lineno: Illegal header name: ".
+ "'$cur{spamheader}'\n";
+ exit 1;
+ }
+ $cur{spamheader} = undef if $cur{spamheader} eq "default";
+ } elsif ($line =~ /^([^@ \t]+@[^@])+\s*/) {
+ my %copy = %cur;
+ $copy{order} = ++$count;
+ $conf->{$line} = \%copy;
+ } elsif ($line =~ /^unprintable\s+/) {
+ $cur{unprintable} = unquote($POSTMATCH);
+ unless ($cur{unprintable} =~ /^(questionmark|unicode)$/) {
+ print STDERR "$file:$lineno: Illegal format for ".
+ "unprintable characters: '$cur{unprintable}'\n";
+ exit 1;
+ }
+ } else {
+ print STDERR "$file:$lineno: Syntax error: '$line'\n";
+ exit 1;
+ }
+ $line = "";
+ }
+ close (CONF);
+ return $conf;
+}
+
+sub unquote {
+ my ($val) = @_;
+ $val =~ s/\s+$//;
+ if ($val =~ /^"(.*)"$/) {
+ $val = $1;
+ $val =~ s/\\"/"/g;
+ $val =~ s/\\\\/\\/g;
+ }
+ return ($val);
+}
+
+sub expand_pathname {
+ my ($pathname) = @_;
+
+ $pathname =~ s,^\$HOME/,$ENV{'HOME'}/,;
+ $pathname =~ s,^~/,$ENV{'HOME'}/,;
+ $pathname =~ s,^~(\w+)/,(getpwnam($1))[7]."/",e;
+ if ($pathname =~ /^M:/i) {
+ $pathname =~ s,\\,/,g;
+ $pathname =~ s,^M:,$ENV{'HOME'},;
+ }
+ $pathname = undef if $pathname eq "none";
+ return $pathname;
+}
+
+
+sub prompt_for_config {
+ my ($rc) = @_;
+
+ print "No configuration file found: $rc\n";
+ my $ans = prompt ("Do you want to create one? [yes] ");
+ print "\n";
+ if ($ans !~ /^\s*(|y|yes|j|ja)\s*$/i) {
+ print "I take that as a no. Goodbye!\n";
+ return undef;
+ }
+ umask 077;
+ unless (open (RC, ">$rc")) {
+ print STDERR "$rc: $!\n";
+ return undef;
+ }
+ my $user = prompt ("Enter Mailman username: ");
+ print "\n";
+ print RC "username $user\r\n";
+ my $pass = prompt_password("Enter Mailman password: ");
+ print "\n";
+ $pass =~ s/"/\\"/g;
+ print RC "password \"$pass\"\r\n";
+
+ print <<END;
+Listadmin can discard messages with a high spam score automatically.
+A value in the interval 5 to 12 is recommended.
+END
+ my $spam = prompt ("What threshold do you want? [8]");
+ print "\n";
+ $spam =~ s/\s*//g;
+ $spam ||= "8";
+ if ($spam =~ /^\d+$/) {
+ print RC "spamlevel $spam\r\n";
+ } else {
+ print "No automatic discard will be done.\n";
+ }
+ my $extra = <<END;
+
+# If you uncomment the following you will only have to press Return
+# to discard a message:
+#
+# default discard
+
+# Uncomment the following to get a terse transaction log:
+#
+# log "~/.listadmin.log"
+
+END
+ $extra =~ s/\n/\r\n/g;
+ print RC $extra;
+
+ print <<END;
+Now enter the addresses of the lists you maintain. End with an empty
+line.
+END
+ my $list;
+ do {
+ $list = prompt ("> ");
+ print "\n";
+ $list =~ s/\s*//g if $list;
+ print RC "$list\r\n" if $list;
+ } while ($list);
+ close (RC);
+ print <<END;
+
+The configuration has been saved in $rc.
+You can edit this file with an ordinary text editor, such as Notepad,
+Pico, or Emacs. To read about all the configuration options, run
+'man listadmin'.
+
+END
+ return 1;
+}
+
+sub commit_changes {
+ my ($list, $user, $pw, $url, $change, $msgs, $logfile) = @_;
+
+ my $baseurl = mailman_url ($list, $url);
+ my $action = $msgs->{"global"}{"actions"};
+ my $changes = 0;
+ my $update_total = scalar (keys %{$change});
+ my $update_count = 0;
+ my $params = mailman_params ($user, $pw);
+
+ my $log = log_timestamp ($list);
+ # Expand {list}, {subdomain} and {domain}
+ $logfile = mailman_url($list, $logfile);
+
+ for my $id (sort { $a <=> $b } keys %{$change}) {
+ my ($what, $text) = @{$change->{$id}};
+ $params->{$id} = $action->{$what};
+ unless ($what =~ /^s[ar]$/) {
+ # we don't log subscription approval or rejects
+ $log .= sprintf ("%s D:[%s] F:[%s] S:[%s]\n",
+ $what,
+ $msgs->{$id}{"date"},
+ $msgs->{$id}{"from"},
+ $msgs->{$id}{"subject"});
+ }
+ if ($what =~ /^s?r$/) {
+ $params->{"comment-$id"} = $text;
+ }
+ ++$changes;
+
+ # HTTP does not specify a maximum size for a POST request, so
+ # we could do this as one request. However, Apache is usually
+ # set up to close the connection after the CGI script has run
+ # for 5 minutes, so we reduce the size of each request to be
+ # nice to slow servers.
+
+ if ($changes >= 100) {
+ $update_count += $changes;
+ printf("sending %d updates to server, %d left \r",
+ $changes, $update_total - $update_count);
+ submit_http ($baseurl, $params, $log, $logfile);
+ $log = log_timestamp ($list);
+ $changes = 0;
+ $params = mailman_params ($user, $pw);
+
+ # even if time has run out, we will always submit at least
+ # one batch of data.
+ if (time > $time_limit) {
+ print "\nTime's up, won't submit the other changes\n";
+ last;
+ }
+ }
+ }
+ submit_http ($baseurl, $params, $log, $logfile)
+ if $changes;
+ print (" " x 72, "\r") if $update_count > 0;
+}
+
+sub log_timestamp {
+ my $list = shift;
+
+ my ($sec, $min, $hour, $mday, $mon, $year) = (localtime (time))[0..5];
+ return (sprintf ("submitting %s %04d-%02d-%02dT%02d:%02d:%02d\n",
+ $list, $year+1900, $mon+1, $mday, $hour, $min, $sec));
+}
+
+sub add_subscribers {
+ my ($list, $config, $mail, @addresses) = @_;
+
+ die unless @addresses;
+
+ fetch_meta_members($list, $config);
+
+ my %params = (username => $config->{user},
+ adminpw => $config->{password},
+ subscribe_or_invite => 0, # Mailman 2.x
+ send_notifications_to_list_owner => 0, # Mailman 2.x
+ send_welcome_message_to_this_batch => 0, # Mailman 2.x
+ send_welcome_msg_to_this_batch => 0, # Mailman 1.2
+ meta_members => $config->{meta_members}, # Mailman 1.2
+ subscribees => join("\n", @addresses));
+ my $url = mailman_url($list, $config->{adminurl}, "", "members");
+ my $resp = $ua->post($url, \%params);
+ return $resp->status_line unless $resp->is_success;
+
+ my $result = parse_subscribe_response($resp->content);
+
+ if (!$mail) {
+ my %left = map { $_ => 1 } @addresses;
+ for my $failed (keys %{$result}) {
+ unless ($result->{$failed} =~ get_trans_re("already_member")) {
+ delete $left{$failed};
+ }
+ }
+ @addresses = keys %left;
+ } else {
+ # We only need to reset "nomail" on the users who already were
+ # members.
+ @addresses = ();
+ for my $failed (keys %{$result}) {
+ if ($result->{$failed} =~ get_trans_re("already_member")) {
+ push(@addresses, $failed);
+ }
+ }
+ }
+ if (@addresses) {
+ %params = (username => $config->{user},
+ adminpw => $config->{password},
+ user => \@addresses,
+ meta_members => $config->{meta_members}, # Mailman 1.2
+ setmemberopts_btn => "submit"); # Mailman 2.x
+ for my $a (@addresses) {
+ $params{$a . "_nomail"} = "on" unless $mail;
+ $params{$a . "_subscribed"} = "on"; # Mailman 1.2
+ }
+ $resp = $ua->post($url, \%params);
+ return $resp->status_line unless $resp->is_success;
+ }
+
+ return $result;
+}
+
+sub remove_subscribers {
+ my ($list, $config, @addresses) = @_;
+
+ fetch_meta_members($list, $config);
+
+ my $url = mailman_url($list, $config->{adminurl}, "", "members");
+
+ # In Mailman 1.2, unsubscription happens when an address is
+ # mentioned in "user" without a corresponding
+ # "$address_subscribed" parameter
+ my %params = (username => $config->{user},
+ adminpw => $config->{password},
+ setmemberopts_btn => "submit", # Mailman 2.x
+ meta_members => $config->{meta_members}, # Mailman 1.2
+ user => \@addresses);
+ for my $a (@addresses) {
+ $params{$a . "_unsub"} = "on"; # Mailman 2.x
+ }
+ my $resp = $ua->post($url, \%params);
+ return $resp->status_line unless $resp->is_success;
+
+ return parse_subscribe_response($resp->content);
+}
+
+
+sub parse_subscribe_response {
+ my ($page) = @_;
+
+ # Normalise, to make parsing easier (Hack!)
+ $page =~ s/<h3\>/\<h5\>/ ;
+ $page =~ s/<\/h3\>/\<\/h5\>/;
+
+ # In Mailman 1.2 and 2.0, you will not get an explicit success
+ # report when removing subscribers, so we only return the
+ # failures since the successes can be inferred anyway.
+
+ my %failure = ();
+
+ my $parse = HTML::TokeParser->new(\$page) || die;
+
+ while ($parse->get_tag ("h5")) {
+ my $h5 = $parse->get_text ("/h5");
+
+ $parse->get_tag ("ul") || die;
+ my $ul = $parse->get_text ("/ul") || die;
+
+ if ($h5 =~ get_trans_re("subscr_success")) {
+ # hooray!
+ } elsif ($h5 =~ get_trans_re("subscr_error")) {
+ for (split(/\n/, $ul)) {
+ chomp;
+ if (/^\s*(.*?)\s*--\s*(.*)/) {
+ $failure{$1} = $2;
+ }
+ }
+ } else {
+ $ul =~ s/\n/\n\t/g;
+ print STDERR "You have an unusual Mailman output. Please mail ".
+ "this message to\n$maintainer\n:\n".
+ "\t[$h5]\n\t[$ul]\nThanks!\n";
+ }
+ $parse->get_tag ("p") || die;
+ }
+
+ return \%failure;
+}
+
+sub list_subscribers {
+ my ($list, $config) = @_;
+
+ fetch_meta_members($list, $config);
+ my $url = mailman_url($list, $config->{adminurl}, "", "members");
+ my %params = (username => $config->{user},
+ adminpw => $config->{password},
+ meta_members => $config->{meta_members},
+ chunk => 0);
+ my $resp = $ua->post($url, \%params);
+ unless ($resp->is_success) {
+ print "$url: ", $resp->status_line, "\n";
+ return ();
+ }
+
+ my @addresses = ();
+ my ($parse, $page, $tag);
+
+ member_letter:
+ for my $letter ("a" .. "z") {
+ my $chunk = 0;
+
+ $params{chunk} = $chunk;
+
+ # Mailman 2.x specifically looks at QUERY_STRING, so chunk and
+ # letter can't be parameters to POST. However, Mailman 1.x
+ # only looks at chunk in the POST parameters.
+ $resp = $ua->post("$url?letter=$letter&chunk=$chunk", \%params)
+ unless $letter eq "a";
+
+ while ($resp->is_success) {
+ $page = $resp->content;
+ $parse = HTML::TokeParser->new(\$page);
+ my $count = 0;
+ my $repeated = 0;
+ my $later_letter = 0;
+ while ($tag = $parse->get_tag("input")) {
+ my $attr = $tag->[1];
+ if ($attr->{type} =~ /^hidden$/i &&
+ $attr->{name} =~ /^user$/i) {
+ ++$count;
+ my $address = $attr->{value};
+ unless ($address =~ /\@/) {
+ # Mailman 2.x adds URL-encoding
+ $address =~ s/%([0-9a-fA-F]{2})/sprintf("%c", hex($1))/ge;
+ }
+ ++$later_letter if lc(substr($address, 0, 1)) gt $letter;
+ if (grep { $_ eq $address } @addresses) {
+ ++$repeated;
+ } else {
+ push(@addresses, $address);
+ }
+ }
+ }
+ last if $count == 0;
+
+ # In Mailman 1.x, "letter" is a no-op, so $later_letter
+ # will ~always be true and should be ignored. Increase
+ # chunk until we see repeats.
+
+ # In Mailman 2.x, we need to iterate through both letter
+ # and chunk, but if the list has few members, they will
+ # all be listed and letter and chunk are ignored. Also,
+ # if there are no members for a given letter, the whole
+ # list will be returned.
+
+ if ($repeated) {
+ last member_letter if $later_letter;
+ next member_letter;
+ }
+
+ # The maximum number of addresses on each page can be
+ # configured, by default it is set to 30, but it could in
+ # theory be less. To save time, we assume that we have
+ # all the members if we got less than 20 addresses.
+ next member_letter if $count < 20;
+
+ ++$chunk; $params{chunk} = $chunk;
+ $resp = $ua->post("$url?letter=$letter&chunk=$chunk", \%params);
+ }
+ }
+ if ($config->{meta_members}) {
+ push(@addresses, split(/\n+/, $config->{meta_members}));
+ }
+ return @addresses;
+}
+
+# This code is only useful on the patched Mailman 1.2 installation at
+# UiO. Notice that it uses GET without any parameters to fetch the
+# page, since otherwise it will clear the meta members.
+# Unfortunately, this means we need to use cookies to log in, and this
+# requires a new Perl module, WWW::Mechanize. Since this is such a
+# site specific feature, we hide the requirement so listadmin runs
+# even without the module.
+
+sub fetch_meta_members {
+ my ($list, $config) = @_;
+
+ return if defined $config->{meta_members}; # already fetched
+ return unless $config->{meta_member_support} || $list =~ /\buio\.no$/i;
+
+ # We will only attempt this once, so make a note we've tried.
+ $config->{meta_members} = "";
+
+ unless (eval "require WWW::Mechanize; 1") {
+ print "WARNING: Meta members may be removed, install WWW::Mechanize\n";
+ return;
+ }
+
+ my $agent = WWW::Mechanize->new(autocheck => 1);
+ $agent->get(mailman_url($list, $config->{adminurl}));
+ $agent->submit_form(fields => { username => $config->{user},
+ adminpw => $config->{password}});
+
+ $agent->get(mailman_url($list, $config->{adminurl}, "", "members"));
+
+ my $page = $agent->content();
+ my $parse = HTML::TokeParser->new(\$page);
+ my $tag = $parse->get_tag("textarea");
+ $tag = $parse->get_tag("textarea");
+ return unless defined $tag; # silently ignore the failure
+
+ if ($tag->[1]->{name} eq "meta_members") {
+ $config->{meta_members} = $parse->get_trimmed_text("/textarea");
+ }
+}
+
+sub remove_matching_subscribers {
+ my ($list, $config, $pattern) = @_;
+ my @addresses = list_subscribers($list, $config);
+ if (defined($pattern) and $pattern ne "") {
+ @addresses = grep { /$pattern/ } @addresses;
+ }
+ my $msg = remove_subscribers($list, $config, @addresses);
+ if ($msg eq "OK") {
+ print "Removed:\n ", join("\n ", @addresses), "\n";
+ } else {
+ print $msg, "\n";
+ }
+}
+
+sub read_address_file {
+ my ($file, $assert_nonempty) = @_;
+ my @list = ();
+ open(F, $file) || die "$file: $!\n";
+ while (<F>) {
+ s/(^|\s)\#.*//;
+ s/^\s+//;
+ s/\s+$//;
+ next if /^$/;
+ push(@list, $_);
+ }
+
+ die "$file: no lines, aborting\n" if $assert_nonempty && @list == 0;
+ return @list;
+}
+
+sub submit_http {
+ my ($url, $params, $log, $logfile) = @_;
+
+ my $opened;
+ if ($logfile) {
+ if (open (LOG, ">>$logfile")) {
+ LOG->autoflush(1);
+ # Perhaps we should force the encoding to US-ASCII
+ # instead, but I think this is more DWIM compliant.
+ binmode LOG, ":encoding($term_encoding)";
+ $opened = 1;
+ local $SIG{__WARN__} = sub {}; # see comment elsewhere
+ print LOG $log;
+ } else {
+ print STDERR "WARNING: Failed to append to $logfile: $!\n";
+ }
+ }
+ my $ret = $ua->post ($url, $params);
+ print STDERR "server returned error\n", $ret->error_as_HTML, "\n"
+ unless $ret->is_success;
+ if ($opened) {
+ if ($ret->is_success) {
+ print LOG "changes sent to server\n";
+ } else {
+ print LOG "server returned error\n", $ret->error_as_HTML, "\n";
+ }
+ close (LOG);
+ }
+}
+
+sub got_match {
+ my ($str, $pattern) = @_;
+
+ return undef unless defined ($str) && $pattern;
+
+ # If the pattern is delimited by slashes, run it directly ...
+ if ($pattern =~ m,^/(.*)/([ix]*)$,) {
+ eval "\$str =~ $pattern";
+ } else {
+ $str =~ $pattern;
+ }
+}
+
+sub restore_echo_and_exit {
+ system("stty echo");
+ print "\n";
+ exit(1);
+}
+
+sub prompt_password {
+ my ($prompt) = @_;
+ my $answer;
+ my $echooff;
+
+ # This might not work, since some versions of readline screw up
+ # and turn on "echo" for us :-(
+
+ $SIG{'INT'} = $SIG{'TERM'} = \&restore_echo_and_exit;
+ system("stty -echo 2>/dev/null");
+ if ($? == 0) {
+ $echooff = 1;
+ } else {
+ $prompt .= "(will appear on screen): ";
+ }
+ $answer = prompt($prompt);
+ if ($echooff) {
+ print "\n";
+ system("stty echo");
+ $SIG{'INT'} = $SIG{'TERM'} = 'DEFAULT';
+ }
+ return $answer;
+}
+
+sub prompt {
+ # $term is a global variable. we initialise it here, so that it
+ # is only done if the user actually needs prompting.
+ $term = new Term::ReadLine 'listadmin'
+ unless $term;
+ my $answer = $term->readline(@_);
+ # readline turns off autoflush, re-enable it
+ $| = 1;
+ return $answer;
+}
+
+sub config_order {
+ $config->{$a}{order} <=> $config->{$b}{order};
+}
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-26 09:51:13 +0000