diff options
author | Noèl Köthe <noel@debian.org> | 2007-01-20 21:21:17 +0100 |
---|---|---|
committer | Unit 193 <unit193@ubuntu.com> | 2019-12-05 16:35:12 -0500 |
commit | dc97dccb98cf97044be59cca6040ccd2a7a498cf (patch) | |
tree | a9cad281b5f06e153c051acc9d913e0b493b3704 | |
parent | 23192d551e36119e34299ec0f8669b4dcaf69227 (diff) | |
parent | ec9199209989ae6e6be918680db606928439650f (diff) | |
download | listadmin-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-- | Makefile | 2 | ||||
-rw-r--r-- | debian/changelog | 8 | ||||
-rw-r--r-- | debian/control | 2 | ||||
-rw-r--r-- | listadmin.man | 54 | ||||
-rwxr-xr-x | listadmin.pl | 595 | ||||
-rw-r--r-- | listadmin.txt | 67 |
6 files changed, 613 insertions, 115 deletions
@@ -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. "К", 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> |