aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorLibravatarNoèl Köthe <noel@debian.org>2007-01-20 21:21:17 +0100
committerLibravatarUnit 193 <unit193@ubuntu.com>2019-12-05 16:35:12 -0500
commitdc97dccb98cf97044be59cca6040ccd2a7a498cf (patch)
treea9cad281b5f06e153c051acc9d913e0b493b3704
parent23192d551e36119e34299ec0f8669b4dcaf69227 (diff)
parentec9199209989ae6e6be918680db606928439650f (diff)
downloadlistadmin-dc97dccb98cf97044be59cca6040ccd2a7a498cf.tar.bz2
listadmin-dc97dccb98cf97044be59cca6040ccd2a7a498cf.tar.xz
listadmin-dc97dccb98cf97044be59cca6040ccd2a7a498cf.tar.zst
Import Debian changes 2.36-1debian/2.36-1
listadmin (2.36-1) unstable; urgency=low * new upstream release (Closes: Bug#406603) * added libtext-reform-perl dependency
-rw-r--r--Makefile2
-rw-r--r--debian/changelog8
-rw-r--r--debian/control2
-rw-r--r--listadmin.man54
-rwxr-xr-xlistadmin.pl595
-rw-r--r--listadmin.txt67
6 files changed, 613 insertions, 115 deletions
diff --git a/Makefile b/Makefile
index 72e4b4a..0396efd 100644
--- a/Makefile
+++ b/Makefile
@@ -1,7 +1,7 @@
SHELL = /bin/sh
INSTALL = install -c
-VERSION = 2.32
+VERSION = 2.36
PREFIX = /usr/local
BINDIR = $(PREFIX)/bin
diff --git a/debian/changelog b/debian/changelog
index d913cef..4b289c1 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,11 @@
+listadmin (2.36-1) unstable; urgency=low
+
+ * new upstream release
+ (Closes: Bug#406603)
+ * added libtext-reform-perl dependency
+
+ -- Noèl Köthe <noel@debian.org> Sat, 20 Jan 2007 21:21:17 +0100
+
listadmin (2.32-1) unstable; urgency=medium
* new upstream release
diff --git a/debian/control b/debian/control
index a451266..155bb3d 100644
--- a/debian/control
+++ b/debian/control
@@ -7,7 +7,7 @@ Standards-Version: 3.7.2
Package: listadmin
Architecture: all
-Depends: ${shlibs:Depends}, ${misc:Depends}, libwww-perl, libcrypt-ssleay-perl
+Depends: ${shlibs:Depends}, ${misc:Depends}, libwww-perl, libcrypt-ssleay-perl, libtext-reform-perl
Description: command line mailman moderator queue manipulation
listadmin is a command line tool to manipulate the queues of messages
held for moderator approval by mailman. It is designed to keep user
diff --git a/listadmin.man b/listadmin.man
index 1043143..9325df5 100644
--- a/listadmin.man
+++ b/listadmin.man
@@ -6,7 +6,8 @@
.SH NAME
listadmin \- process messages held by Mailman for approval
.SH SYNOPSIS
-.B "listadmin [-f \fIconfigfile\fP] [-t \fIminutes\fP] [\fIlistname\fP]"
+.B "listadmin [-f \fIconfigfile\fP] [-t \fIminutes\fP] [{-a|-r} \fIfile\fP]
+ [-l] [\fIlistname\fP]"
.SH DESCRIPTION
.I listadmin
is a textual alternative to Mailman's WWW interface for administering
@@ -18,6 +19,14 @@ default (\fB~/.listadmin.ini\fP).
.IP "-t \fIminutes\fP"
Stop processing after \fIminutes\fP has passed. Mostly useful for
completely automated configurations of \fBlistadmin\fP.
+.IP "-a \fIfile\fP"
+Add e-mail addresses listed in \fIfile\fP (one address per line) to
+subscriber list. The welcome message is suppressed.
+.IP "-r \fIfile\fP"
+Remove e-mail addresses listed in \fIfile\fP (one address per line)
+from the subscriber list.
+.IP "-l"
+Display the subscriber list.
.IP "\fIlistname\fP"
Only process the lists matching \fIlistname\fP. Specify a complete
address, a substring or a regular expression.
@@ -41,7 +50,8 @@ A directive affects all the mailing lists addresses which follow after
it in the configuration file. The directives are:
.RS
.IP "username \fIusername\fP"
-Specifies the username to use for authentication.
+Specifies the username to use for authentication. (Not all Mailman
+servers require a username.)
.IP "password \fIpassword\fP"
Specifies the password to use for authentication.
.IP "adminurl \fIurl\fP"
@@ -125,6 +135,11 @@ very useful. It is better to get automatic accept and reject
behaviour by changing the Mailman configuration.
.IP "confirm \fIyes|no\fP"
Before submitting changes, ask for confirmation. Default is "yes".
+.IP "unprintable \fIquestionmark|unicode\fP"
+If the subject or sender address contains characters the terminal
+can't display, they will be replaced by either "<?>" (in
+\fIquestionmark\fP mode, the default) or something like "<U+86a8>" (in
+\fIunicode\fP mode).
.IP "log \fIfilename\fP"
Changes submitted to the web interface are logged. All the changes
for one list are sent in batches at the end of processing. The format
@@ -163,6 +178,9 @@ View Full, display the complete message, including headers.
View Time, display the Date header from the message.
.IP \fInumber\fP
Jump forward or backward to message \fInumber\fP.
+.IP u
+Go back to the previous message and undo the last approve, discard or
+reject action.
.IP /\fIpattern\fP
Search (case-insensitively) for the next message with matching From or
Subject. If \fIpattern\fP is left out, the previous value will be
@@ -171,6 +189,15 @@ used.
As above, but backwards.
.IP .
Redisplay information about current message.
+.IP add [\fIaddress\fP]
+Add \fIaddress\fP as subscriber to the list with "nomail" enabled. If
+\fIaddress\fP is left out, use the sender of the current message.
+.IP list [\fIpattern\fP]
+List subscriber addresses matching \fIpattern\fP, or the full list if
+no \fIpattern\fP is specified.
+.IP rem \fIaddress\fP
+Remove \fIaddress\fP from the subscriber list. Note: there is no undo
+for this action.
.IP q
Quit processing this list and go on to the next.
.RE
@@ -179,7 +206,21 @@ Changes will not take effect until the end of the list has been
reached. At that time, the user will be prompted whether the changes
should be submitted to Mailman (see also "confirm" directive above).
-.SH EXAMPLE
+.SH EXAMPLES
+To process only the lists of a single domain, specify the domain as
+the pattern:
+.nf
+.ta +3m
+ listadmin example.com
+.fi
+
+To disable the printing of characters outside US-ASCII, set the locale
+appropriately:
+.nf
+.ta +3m
+ env LC_CTYPE=C listadmin
+.fi
+
An example configuration file:
.nf
.ta +3m +4n
@@ -226,9 +267,10 @@ The default configuration file.
.SH BUGS
The HTML parser is quite fragile and depends on Mailman not to change
the format of its generated code.
-
-ISO 8859-1 environment is assumed.
-
+.PP
+An extra blank line is sometimes added to the subject when it contains
+double width characters (e.g. Chinese). This is probably a bug in
+Text::Reform.
.SH AUTHOR
Kjetil T. Homme <kjetilho+listadmin@ifi.uio.no>
.br
diff --git a/listadmin.pl b/listadmin.pl
index 3efc557..f037b54 100755
--- a/listadmin.pl
+++ b/listadmin.pl
@@ -1,7 +1,7 @@
#! /usr/bin/perl -w
#
-# listadmin version 2.31
-# Written 2003 - 2006 by
+# listadmin version 2.36
+# Written 2003 - 2007 by
# Kjetil Torgrim Homme <kjetilho+listadmin@ifi.uio.no>
#
# Thank you, Sam Watkins and Bernie Hoeneisen, for contributions and
@@ -16,6 +16,9 @@ use MIME::QuotedPrint;
use Data::Dumper;
use Term::ReadLine;
use Getopt::Std;
+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;
@@ -23,25 +26,35 @@ my $rc = $ENV{"HOME"}."/.listadmin.ini";
sub usage {
print STDERR <<_end_;
-Usage: $0 [-f CONFIGFILE] [-t MINUTES] [LISTNAME]
+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.
+ -a FILE Add e-mail addresses in FILE to list
+ -r FILE Remove e-mail addresses in FILE to list
+ -l List subscribers
LISTNAME Only process lists with name matching LISTNAME.
+
+If -a, -r or -l is given, LISTNAME must match exactly one list.
_end_
exit (64);
}
-my $term;
-my $ua = new LWP::UserAgent ("timeout" => 600);
+our ($opt_f, $opt_t, $opt_a, $opt_r, $opt_l);
-our ($opt_f, $opt_t);
+usage() unless getopts('f:t:a:r:l');
-usage() unless getopts('f:t:');
$rc = $opt_f if $opt_f;
usage() if defined $opt_t && $opt_t !~ /\d/ && $opt_t !~ /^\d*(\.\d*)?$/;
+usage() if defined $opt_a && defined $opt_r;
+usage() if defined $opt_l && (defined $opt_a || defined $opt_r);
+
+my $ua = new LWP::UserAgent ("timeout" => 900);
my $time_limit = time + 60 * ($opt_t || 24*60);
+my $term;
+my $term_encoding = langinfo(CODESET());
+binmode STDOUT, ":encoding($term_encoding)";
# Turn on autoflush on STDOUT
$| = 1;
@@ -66,21 +79,38 @@ if (@ARGV) {
@lists = sort config_order keys %{$config}
}
-my ($num, $count, $list, $from, $subject, $reason, $spamscore);
+if (@lists > 1 && (defined $opt_r || defined $opt_a || defined $opt_l)) {
+ print STDERR "Too many matching lists\n";
+ usage();
+}
-format STDOUT =
+my $list = $lists[0];
+my $subscribe_result;
+if (defined $opt_a) {
+ my @addresses = read_address_file($opt_a, 1);
+ $subscribe_result = add_subscribers($list, $config->{$list}, 0, @addresses);
+} elsif (defined $opt_r) {
+ my @addresses = read_address_file($opt_r, 1);
+ $subscribe_result = remove_subscribers($list, $config->{$list}, @addresses);
+}
+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);
+}
-@<<<<<<< ========== @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-sprintf("[%d/%d]", $num, $count), $list." "."=" x (51 - length($list))
-From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- $from
-Subject: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- $subject
-~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- $subject
-Reason: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Spam? @<<
- $reason, $spamscore
-.
+my ($num, $count, $from, $subject, $reason, $spamscore);
for (@lists) {
@@ -125,6 +155,7 @@ for (@lists) {
} else {
print "\n";
}
+ $config->{$list}{"password"} = $pw;
my %change = ();
@@ -140,16 +171,21 @@ for (@lists) {
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.
+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$/) {
+ } 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;
}
@@ -208,7 +244,7 @@ sub process_subscriptions {
$change->{$id} = [ "sr", $r ];
last;
} else {
- print STDERR <<end;
+ print STDERR <<"_end_";
Choose one of the following actions by typing the corresponding letter
and pressing Return.
@@ -217,7 +253,7 @@ and pressing Return.
s Skip -- do not decide now, leave it for later
q Quit -- go on to approving messages
-end
+_end_
}
}
}
@@ -242,8 +278,19 @@ sub approve_messages {
} else {
$dont_skip_forward = 1;
}
- my $prompt = 'Approve/Reject/Discard/Skip/view Body/view Full/jump #/Help/Quit';
+ 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;
@@ -252,8 +299,20 @@ sub approve_messages {
$subject = $info->{$id}{"subject"} || "";
$reason = $info->{$id}{"reason"};
$spamscore = $info->{$id}{"spamscore"};
- write;
-
+ {
+ # 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 = "";
@@ -287,12 +346,15 @@ sub approve_messages {
$pr .= " ? ";
$ans ||= prompt ($pr);
$ans = "q" unless defined $ans;
- $ans =~ s/\s+//g;
+ $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;
@@ -301,9 +363,56 @@ sub approve_messages {
$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(\s+|$)/) {
+ my $addr = $POSTMATCH || $from;
+ my $res = add_subscribers($list, $config, 1, $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;
@@ -346,37 +455,56 @@ sub approve_messages {
goto redo_reject;
}
+ push(@undo_list, [ $num ]);
$change->{$id} = [ "r", $r ];
$dont_skip_forward = 0;
last;
} elsif ($ans eq "f") {
- print $info->{$id}{"headers"}, "\n\n", $info->{$id}{"body"};
+ # 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 = lc $info->{$id}{"headers"};
+ my $head = $info->{$id}{"headers"};
my $text = $info->{$id}{"body"};
- if ($head =~ m,content-type:\s+text/,) {
- my $charset = "UNKNOWN";
- if ($head =~ /charset="?(iso-8859-15?|us-ascii|utf-8)"?/) {
- $charset = $1;
- }
- if ($head =~ /content-transfer-encoding:\s+quoted-print/) {
+ 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 ($head =~ /content-transfer-encoding:\s+base64/) {
- $text = MIME::Base64::decode_base64($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;
}
- $text = utf8_to_latin1 ($text) if $charset eq "utf-8";
}
+ 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 ".") {
- # write modifies $subject, so reinitialise it
- $subject = $info->{$id}{"subject"} || "";
- write;
+ goto redraw;
} elsif ($ans eq "") {
# nothing.
} else {
@@ -384,18 +512,22 @@ sub approve_messages {
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 #
- /pattern -- search for next message with matching From or Subject
- ?pattern -- search for previous message with matching From or Subject
- . -- redisplay entry
- q Quit -- go on to the next list
+ 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 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;
@@ -435,7 +567,7 @@ sub uio_adminurl {
}
sub mailman_url {
- my ($list, $pattern, $params) = @_;
+ my ($list, $pattern, $params, $action) = @_;
my ($lp, $domain) = split ('@', $list);
@@ -448,6 +580,10 @@ sub mailman_url {
$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;
}
@@ -465,6 +601,14 @@ sub get_list {
return {'servererror' => $resp->status_line, 'url' => $url};
}
$page = $resp->content;
+ if ($page eq "") {
+ if (time - $starttime > 60) {
+ print "Mailman server timed out?\n";
+ } else {
+ print "empty page\n";
+ }
+ return {};
+ }
my $dumpdir = $config->{"dumpdir"};
if (defined $dumpdir) {
if (open (DUMP, ">$dumpdir/dump-$list.html")) {
@@ -611,27 +755,101 @@ sub parse_approvals {
} until ($token->[0] eq "S" && lc ($token->[1]) eq "input");
}
-# NB! lossy!
-sub utf8_to_latin1 {
- my ($s) = @_;
- $s =~ s/([\x80-\xff][\x80-\xbf]*)/&utf8_to_latin1_char($1)/ge;
- return $s;
-}
+sub guess_charset {
+ my ($charset, $text) = @_;
-sub utf8_to_latin1_char {
- my($first, @rest) = unpack('C*', $_[0]);
- $first ^= 0xC2;
- return chr($first * 0x40 + $rest[0]) if $first < 2 && @rest == 1;
- # We simply remove the other codes, they obviously won't fit in Latin1.
- return "";
+ # 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 $text = shift;
+ my ($charset, $encoded_word) = @_;
+ my $text = $encoded_word;
$text =~ s/_/ /g;
- return MIME::QuotedPrint::decode ($text);
+ $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);
@@ -660,22 +878,11 @@ sub parse_approval {
$parse->get_tag ("td") || die;
$reason = $parse->get_trimmed_text("/td");
}
- my $utf8 = 0;
- # this will also decode invalid tokens, where the encoded word is
- # concatenated with other letters, e.g. foo=?utf-8?q?=A0=F8?=
- $subject =~ s/=\?(us-ascii|utf-8|iso-8859-15?)\?q\?(.*?)\?=/
- decode_rfc2047_qp($2)/ieg;
- $utf8 ||= 1 if defined $1 && $1 =~ /utf-8/i;
- $subject =~ s/=\?(us-ascii|utf-8|iso-8859-15?)\?b\?(.*?)\?=/
- MIME::Base64::decode_base64($2)/ieg;
- $utf8 ||= 1 if defined $1 && $1 =~ /utf-8/i;
- $subject = utf8_to_latin1 ($subject) if $utf8;
-
$parse->get_tag ("tr") || die; # Action:
my $tag = $parse->get_tag ("input") || die;
$id = $tag->[1]{"name"};
- $data->{$id} = { "from" => $from,
+ $data->{$id} = { "from" => decode_rfc2047($from, $config),
"subject" => $subject,
"reason" => $reason };
@@ -725,9 +932,23 @@ sub parse_approval {
$body = $POSTMATCH;
$headers = $PREMATCH;
}
+ $headers =~ s/\n(\s)/$1/g; # Header folding
$headers =~ s/^\s+//;
- $body .= "\n" unless $body =~ /\n$/;
$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);
@@ -770,6 +991,7 @@ sub read_config {
my $confirm = 1;
my $url;
my $spamheader;
+ my $unprintable = "questionmark";
my %patterns = map { $_ => undef; }
qw (not_spam_if_from
not_spam_if_subject
@@ -901,9 +1123,17 @@ sub read_config {
"logfile" => $logfile,
"dumpdir" => $dumpdir,
"spamheader" => $spamheader,
+ "unprintable" => $unprintable,
%patterns,
"order" => ++$count,
};
+ } elsif ($line =~ /^unprintable\s+/) {
+ $unprintable = unquote($POSTMATCH);
+ unless ($unprintable =~ /^(questionmark|unicode)$/) {
+ print STDERR "$file:$lineno: Illegal format for ".
+ "unprintable characters: '$unprintable'\n";
+ exit 1;
+ }
} else {
print STDERR "$file:$lineno: Syntax error: '$line'\n";
exit 1;
@@ -1042,18 +1272,13 @@ sub commit_changes {
}
++$changes;
- # HTTP does not specify a maximum length for the URI in a GET
- # request, but it recommends that a server does not rely on
- # clients being able to send URIs larger than 255 octets. the
- # reject reason can be very long, so theoretically, we can
- # overshoot that limit even if we change the 500 below into
- # 250. Mailman has been observed to reject URI's ~3400 octets
- # long, but accept 8021. the limit is probably based on the
- # time taken to process, rather than the length of the URI.
- # in times with high load on the Mailman server, it's best to
- # keep the amount of work per request down.
-
- if ($changes > 50) {
+ # 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);
@@ -1083,6 +1308,186 @@ sub log_timestamp {
$list, $year+1900, $mon+1, $mday, $hour, $min, $sec));
}
+sub add_subscribers {
+ my ($list, $config, $nomail, @addresses) = @_;
+
+ die unless @addresses;
+
+ 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
+ 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 ($nomail) {
+ my %left = map { $_ => 1 } @addresses;
+ for my $failed (keys %{$result}) {
+ delete $left{$failed};
+ }
+ @addresses = keys %left;
+
+ %params = (username => $config->{user},
+ adminpw => $config->{password},
+ user => \@addresses,
+ setmemberopts_btn => "submit"); # Mailman 2.x
+ for my $a (@addresses) {
+ $params{$a . "_nomail"} = "on";
+ $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) = @_;
+
+ 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
+ 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 =~ /Successfully (un)?subscribed/i) {
+ # hooray!
+ } elsif ($h5 =~ /Error (un)?subscribing/i) {
+ 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\nkjetilho+listadmin\@ifi.uio.no:\n".
+ "\t[$h5]\n\t[$ul]\nThanks!\n";
+ }
+ $parse->get_tag ("p") || die;
+ }
+
+ return \%failure;
+}
+
+sub list_subscribers {
+ my ($list, $config) = @_;
+
+ my $url = mailman_url($list, $config->{adminurl}, "", "members");
+ my %params = (username => $config->{user},
+ adminpw => $config->{password},
+ 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);
+ my $chunk = 0;
+
+ member_chunk:
+ while ($resp->is_success) {
+ $page = $resp->content;
+ $parse = HTML::TokeParser->new(\$page);
+ my $count = 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;
+ }
+ if (grep { $_ eq $address } @addresses) {
+ last member_chunk;
+ } else {
+ push(@addresses, $address);
+ }
+ }
+ }
+ last if $count == 0;
+ ++$params{chunk};
+ $resp = $ua->post($url, \%params);
+ }
+ return @addresses;
+}
+
+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) = @_;
@@ -1090,7 +1495,9 @@ sub submit_http {
if ($logfile) {
if (open (LOG, ">>$logfile")) {
LOG->autoflush(1);
+ binmode LOG, ":encoding(" . langinfo(CODESET()) . ")";
$opened = 1;
+ local $SIG{__WARN__} = sub {}; # see comment elsewhere
print LOG $log;
} else {
print STDERR "WARNING: Failed to append to $logfile: $!\n";
diff --git a/listadmin.txt b/listadmin.txt
index c4bd60c..8072f43 100644
--- a/listadmin.txt
+++ b/listadmin.txt
@@ -4,10 +4,11 @@ NAME
listadmin - process messages held by Mailman for approval
SYNOPSIS
- listadmin [-f configfile] [-t minutes] [listname]
+ listadmin [-f configfile] [-t minutes] [{-a|-r} file] [-l]
+ [listname]"
DESCRIPTION
- listadmin is a textual alternative to Mailman's WWW interface for
+ listadmin is a textual alternative to Mailman’s WWW interface for
administering mailing lists.
OPTIONS
@@ -19,6 +20,16 @@ OPTIONS
Stop processing after minutes has passed. Mostly useful for
completely automated configurations of listadmin.
+ -a file
+ Add e-mail addresses listed in file (one address per line) to
+ subscriber list. The welcome message is suppressed.
+
+ -r file
+ Remove e-mail addresses listed in file (one address per line)
+ from the subscriber list.
+
+ -l Display the subscriber list.
+
listname
Only process the lists matching listname. Specify a complete
address, a substring or a regular expression.
@@ -42,7 +53,8 @@ DIRECTIVES
it in the configuration file. The directives are:
username username
- Specifies the username to use for authentication.
+ Specifies the username to use for authentication. (Not
+ all Mailman servers require a username.)
password password
Specifies the password to use for authentication.
@@ -74,9 +86,9 @@ DIRECTIVES
reject Notify sender that the message was rejected.
discard
- Throw message away, don't notify sender.
+ Throw message away, don’t notify sender.
- skip Don't decide now, leave it for later.
+ skip Don’t decide now, leave it for later.
none Reset to no default action.
@@ -85,7 +97,7 @@ DIRECTIVES
the other rules apply (e.g., spamlevel, discard_if_from
etc.), ie., whenever the user would have been asked what
to do. The same actions as for default are available,
- although reject isn't very useful.
+ although reject isn’t very useful.
spamlevel number
This specifies the threshold for automatic discard of
@@ -103,7 +115,7 @@ DIRECTIVES
default will restore this behaviour.
not_spam_if_from pattern
- If the message's From header matches the pattern, all
+ If the message’s From header matches the pattern, all
automatic actions will be cancelled and you will be asked
what action to take explicitly. The pattern can use Perl
regexp syntax. If enclosed in slashes, some modifiers
@@ -114,14 +126,14 @@ DIRECTIVES
As above, but matches against the Subject header.
discard_if_from pattern
- If the message's From header matches the pattern, it will
+ If the message’s From header matches the pattern, it will
be discarded automatically.
discard_if_subject pattern
As above, but matches against the Subject header.
discard_if_reason pattern
- As above, but matches against Mailman's reason for
+ As above, but matches against Mailman’s reason for
holding the message for approval.
subscription_default action
@@ -134,7 +146,7 @@ DIRECTIVES
reject Notify sender that s/he was not allowed to join
the list.
- skip Don't decide now, leave it for later.
+ skip Don’t decide now, leave it for later.
none Reset to no default action.
@@ -150,6 +162,12 @@ DIRECTIVES
Before submitting changes, ask for confirmation. Default
is "yes".
+ unprintable questionmark|unicode
+ If the subject or sender address contains characters the
+ terminal can’t display, they will be replaced by either
+ "<?>" (in questionmark mode, the default) or something
+ like "<U+86a8>" (in unicode mode).
+
log filename
Changes submitted to the web interface are logged. All
the changes for one list are sent in batches at the end
@@ -174,7 +192,7 @@ INTERACTIVE USE
r Reject the message and notify sender of the decision.
- d Discard the message silently, don't notify sender.
+ d Discard the message silently, don’t notify sender.
s Skip the message, leave its status as pending unchanged.
@@ -187,6 +205,9 @@ INTERACTIVE USE
number Jump forward or backward to message number.
+ u Go back to the previous message and undo the last
+ approve, discard or reject action.
+
/pattern
Search (case-insensitively) for the next message with
matching From or Subject. If pattern is left out, the
@@ -197,13 +218,31 @@ INTERACTIVE USE
. Redisplay information about current message.
+ add Add address as subscriber to the list with "nomail"
+ enabled. If address is left out, use the sender of the
+ current message.
+
+ list List subscriber addresses matching pattern, or the full
+ list if no pattern is specified.
+
+ rem Remove address from the subscriber list. Note: there is
+ no undo for this action.
+
q Quit processing this list and go on to the next.
Changes will not take effect until the end of the list has been
reached. At that time, the user will be prompted whether the changes
should be submitted to Mailman (see also "confirm" directive above).
-EXAMPLE
+EXAMPLES
+ To process only the lists of a single domain, specify the domain as the
+ pattern:
+ listadmin example.com
+
+ To disable the printing of characters outside US-ASCII, set the locale
+ appropriately:
+ env LC_CTYPE=C listadmin
+
An example configuration file:
# A comment, it must appear on a line by itself.
#
@@ -248,7 +287,9 @@ BUGS
The HTML parser is quite fragile and depends on Mailman not to change
the format of its generated code.
- ISO 8859-1 environment is assumed.
+ An extra blank line is sometimes added to the subject when it contains
+ double width characters (e.g. Chinese). This is probably a bug in
+ Text::Reform.
AUTHOR
Kjetil T. Homme <kjetilho+listadmin@ifi.uio.no>