Re: some possibly helpful tools
On Mon, Sep 08, 2003 at 12:51:09AM +0200, Thomas Roessler wrote:
> I just went through the process of de-spamming the debbugs
> installation that is being used for mutt's bug tracking system.
>
> During this exercise, I made heavy use of the attached scripts; they
> may be useful for others. Both need Debbugs::Log.
>
> - cli.pl provides a simple, ed/mailx-like command line interface for
> inspecting debbugs .log files, and deleting records from them.
>
> - wmd.pl uses spamassassin as a weapon of mass deletion.
Heh. You know, cli.pl may just be what I've been looking for to replace
edit-bug, which I wrote about a year ago, but never released properly
because it basically sucked interface-wise. For interest's sake, I've
attached it. I always meant to get round to writing something with a
less bare interface.
One thing that both edit-bug and your scripts probably ought to do is
set the mtime of a log to the Received: date of the last entry left in
it after deletion. This means that you can pretend the spam never
existed for the purpose of bug expiry. I'm not sure if you use the
archiving feature for the mutt installation, but it's occasionally a
problem in Debian that a closed bug never gets archived because it keeps
getting a spam before the allotted 28 days have elapsed. At the moment
we have to touch the log's mtime back by hand in such cases.
> Both tools aren't very polished; if you're interested, please feel
> free to use these for Debian, or to include them with future debbugs
> packages.
Thanks! I'll have a look; they may find their way into a new tools/
directory or something, since I think we have a need for various admin
tools.
Cheers,
--
Colin Watson [cjwatson@flatline.org.uk]
#! /usr/bin/perl -wT
use strict;
require '/etc/debbugs/config';
use lib '/debian/home/cjwatson/cvs/debbugs/source';
use Debbugs::Log;
require '/debian/home/cjwatson/cvs/debbugs/source/cgi/common.pl';
umask 002;
my %friendlystates = (
'autocheck' => 'Auto-forward',
'recips' => 'Mail sent to recipients',
'html' => 'HTML',
'incoming-recv' => 'Incoming message',
);
sub usage (*)
{
my $fh = shift;
print $fh <<EOF;
Usage: $0 <action> [<arguments>] ...
Actions are:
help
list bug# [bug# ...]
list-verbose bug# [bug# ...]
list-msgids bug# [bug# ...]
antispam bug# [bug# ...]
delete|remove bug# message# [message# ...]
EOF
exit 1;
}
sub get_logfile ($)
{
my $bug = shift;
# TODO: there must be a utility function for this somewhere?
my ($bugloc, $bugdir);
$bugloc = getbuglocation($bug, 'log');
$bugdir = getlocationpath($bugloc) if defined $bugloc;
unless (defined $bugdir) {
warn "Bug #$bug not found.\n";
return undef;
}
my $hash = get_hashname($bug);
return "$bugdir/$hash/$bug.log";
}
sub dropped_system ($)
{
my $command = shift;
($<, $>) = ($>, $<);
local $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
system($command);
($<, $>) = ($>, $<);
}
sub read_log ($$)
{
my ($bug, $logfile) = @_;
local *LOG;
open LOG, "< $logfile";
my @records;
unless (eval { @records = read_log_records(*LOG); }) {
warn "Error reading $bug: $@\n";
return undef;
}
close LOG;
my (@groups, @group);
for my $record (@records) {
push @group, $record;
if ($record->{type} =~ /^(?:autocheck|incoming-recv)$/) {
push @groups, [@group];
@group = ();
}
}
push @groups, [@group] if @group; # shouldn't happen, usually
return @groups;
}
sub write_log ($$$)
{
my ($bug, $logfile, $groups) = @_;
my $pid = $$;
$pid =~ /^([0-9]+)$/;
$pid = $1;
local *LOG;
# TODO: locking!
unless (open LOG, "> $logfile.new.$pid") {
warn "Error opening $logfile.new.$pid for writing: $!\n";
return undef;
}
unless (eval { write_log_records(*LOG, @$groups); }) {
warn "Error writing $logfile.new.$pid: $@\n";
return undef;
}
unless (close LOG) {
warn "Error closing $logfile.new.$pid: $!\n";
unlink "$logfile.new.$pid";
return undef;
}
my $pager = $ENV{PAGER} ? $ENV{PAGER} : 'more';
$pager =~ /^([-A-Za-z +,.\/:=@\\^_]+)/;
$pager = $1;
print "Diffing ...\n";
dropped_system("diff -u \Q$logfile\E \Q$logfile.new.$pid\E | $pager");
print "Is this correct? [y/N] ";
my $answer = <STDIN>;
if ($answer =~ /^y/i) {
unless (rename "$logfile.new.$pid", $logfile) {
warn "Error renaming $logfile.new.$pid to $logfile: $!\n";
return undef;
}
} else {
print "Cleaning up ...\n";
unlink "$logfile.new.$pid";
return undef;
}
}
sub print_record ($$$$)
{
my $record = shift;
my $index = shift;
my $pad = shift;
my $style = shift;
my $type = $record->{type};
return if $style eq 'terse' and $type !~ /^(?:autocheck|incoming-recv)$/;
my $innerpad = 0;
if ($style eq 'verbose') {
printf '%s%3d: %s', ' ' x $pad, $index, $friendlystates{$type};
$innerpad = 3;
if ($type eq 'autocheck') {
} elsif ($type eq 'recips') {
my $recips = $record->{recips};
if (defined $recips and ref($recips) eq 'ARRAY') {
print " ", join(', ', @$recips);
} else {
print " in message headers";
}
} elsif ($type eq 'html') {
my $html = $record->{text};
$html =~ s/\n.*//s;
substr($html, 65) = '' if length $html > 65;
print " '$html...'";
} elsif ($type eq 'incoming-recv') {
}
print "\n";
}
if ($type =~ /^(?:autocheck|incoming-recv)$/) {
my $prefix = ($type eq 'autocheck') ? 'X' : '';
my @headers;
my $formatting = $style =~ /^(?:terse|verbose)/;
if ($formatting) {
@headers = qw(from to cc bcc subject date message-id delivered-to);
} elsif ($style eq 'antispam') {
@headers = qw(subject x-spam-status);
} else {
@headers = ($style);
}
my $i = -1;
my $add = "";
for my $header (@headers) {
$i++;
$add = "\n" if ($i == $#headers);
if ($record->{text} =~ /^\Q$prefix\E(\Q$header\E): (.*)/im) {
my ($name, $value) = ($1, $2);
next if $header eq 'delivered-to' and
$value !~ /-(?:forwarded|done)/;
next unless $value =~ /\S/;
if ($formatting) {
print ' ' x ($pad + $innerpad), " $name: $value\n";
} else {
if ($style eq 'antispam') {
if ($header eq 'x-spam-status') {
printf " {%4.1f}", $1 if ($value =~ m|^\S+, hits=(\S+) |);
} else {
my $foo = $value;
$foo =~ s,\s+$,,;
substr($foo, 65) = '' if length $foo > 65;
print $foo;
}
print $add;
} else {
print "$value\n";
}
}
next;
} else {
print $add;
}
}
}
}
sub list ($@)
{
my $style = shift;
usage *STDERR unless @_;
while (@_) {
my $bug = shift;
my ($logfile, $prettybug);
if ($bug =~ m#/#) {
$logfile = $bug;
$prettybug = $bug;
} else {
$logfile = get_logfile $bug;
$prettybug = "bug #$bug";
}
return unless defined $logfile;
my @groups = read_log $bug, $logfile;
my $formatting = $style =~ /^(?:terse|verbose)$/;
print "Messages in $prettybug:\n\n" if $formatting;
for my $msgnum (0 .. $#groups) {
print " Message $msgnum:\n" if $formatting;
printf "[%2d] ", $msgnum if $style eq 'antispam';
my $records = $groups[$msgnum];
for my $i (0 .. $#$records) {
my $record = $records->[$i];
my $pad = $formatting ? 2 : 0;
print_record $record, $i, $pad, $style;
}
}
print "\n" if $formatting;
}
}
sub delete_messages (@)
{
my $bug = shift;
usage *STDERR unless @_;
my $logfile;
if ($bug =~ m#/#) {
$logfile = $bug;
} else {
$bug =~ /^([0-9]+)$/;
$bug = $1;
$logfile = get_logfile $bug;
}
return unless defined $logfile;
my @groups = read_log $bug, $logfile;
while (@_) {
my $message = shift;
if ($message =~ /@/) {
# message-id support not done yet
usage *STDERR;
} elsif ($message !~ /^[0-9]+$/) {
usage *STDERR;
} elsif ($message == 0) {
warn "Refusing to delete message 0!\n";
} else {
$groups[$message] = undef;
}
}
my @records;
for my $group (@groups) {
push @records, @$group if defined $group;
}
write_log $bug, $logfile, \@records;
}
usage *STDERR unless @ARGV;
my $action = shift;
if ($action eq 'help') {
usage *STDOUT;
} elsif ($action eq 'list') {
list('terse', @ARGV);
} elsif ($action eq 'list-verbose') {
list('verbose', @ARGV);
} elsif ($action eq 'list-msgids') {
list('message-id', @ARGV);
} elsif ($action eq 'antispam') {
list('antispam', @ARGV);
} elsif ($action =~ /^(?:delete|remove)/) {
delete_messages(@ARGV);
} else {
usage *STDERR;
}
Reply to: