#!/usr/athena/bin/perl
use warnings;
use strict;
use Getopt::Long;
use File::Basename;

sub USAGE () {
  <<"EndOfOptions";
Usage: @{[basename $0]} [options]
Options:
  -d(elete)             Delete messages above (or at) the maximum score.
  -m(axscore) SCORE     Set the maximum allowed score.
  -h(istogram)          Show a histogram of spam score values.
  -b(egin) NUM          Only process messages starting from number NUM.
  -e(nd) NUM            Only process messages ending at number NUM.
  -i(nfo)               Show selected message headers.
  -o(bnoxious)          Allow running un-nice'd.
EndOfOptions
}

my ($HISTOGRAM, $DELETE, $START, $END, $SHOW_INFO, $OBNOXIOUS);
my $MAXSCORE = 10.0;
GetOptions('delete|d!'    => \$DELETE,
	   'maxscore=f' => \$MAXSCORE,
	   'histogram!' => \$HISTOGRAM,
	   'begin=i'    => \$START,
	   'end=i'      => \$END,
	   'info!'      => \$SHOW_INFO,
	   'onboxious!' => \$OBNOXIOUS)
  or die USAGE;

#$HISTOGRAM = 1 if !defined $MAXSCORE;
$DELETE and !defined $MAXSCORE
  and die "Use of -d(elete) requires -m(axscore)!\n" . USAGE;
$HISTOGRAM or $DELETE
  or  die "One of -h(istogram) or -d(elete) is required!\n" . USAGE;

if (! $OBNOXIOUS) {
  if ($^O eq 'solaris') {
    open my $PRIO, '-|', "priocntl -d $$" or die "open(priocntl|): $!";
    my $class = lc scalar <$PRIO>;
    chomp $class;
    $class =~ s/(?: \s+ (?: class \s+ )? processes )? : \s* $//x;
    $class eq 'interactive' or $class eq 'time sharing'
      or die "I refuse to run in the '$class' scheduling class!\n";
    my @fields = split ' ', lc scalar <$PRIO>;
    my @values = split ' ', scalar <$PRIO>;
    @fields == @values or die "Failed to parse priocntl output!\n";
    my %val = map +($fields[$_] => $values[$_]), 0 .. $#fields;
    my ($pri) = grep /upri$/, keys %val
      or die "Priority not found among keys: @fields\n";
    $pri = $val{$pri};
    $pri =~ /^-?\d+$/ or die "Unexpected priority value '$pri'.\n";
    $pri < 0
      or die "I refuse to run at $class priority $pri!  Please 'nice' me!\n";
  }
}

$|=1;

sub request_pipe ( @ ) {
  my (@reqs) = @_;

  my $pid = open my $FH, '-|', '-';
  defined $pid or die "open(-|): $!";

  if (! $pid) {
    # child
    exec 'pop', map +( '-request' => $_ ), ( 'c', @reqs, 'q' );
    die "exec: $!";
  }

  $FH;
}

use constant OUT_DBG  => 0;
use constant STAT_DBG => 0;

use constant HEADER_BLOCK => 100;
use constant HEADER_LABEL => 2500;
use constant HIST_MAX => 8;

use constant DELETE_BLOCK => 100;

sub request_foreach ( $@ ) {
  my $cb = shift;
  my $FH = request_pipe(@_);
  while (<$FH>) {
    chomp;
    #print ">> '$_'\n" if OUT_DBG;
    &$cb;
  }
  #print ">> (end)\n" if OUT_DBG;  
}

sub request_out ( @ ) {
  my @data;
  request_foreach sub { push @data, $_; }, @_;
  #my $size = @data;
  #print ":: request_out: $. blocks read, $size stored\n" if STAT_DBG;  
  @data;
}

sub request_out_X ( @ ) {
  my $FH = request_pipe(@_);
  my @data;
  while (<$FH>) {
    chomp;
    #print ">> '$_'\n" if OUT_DBG;
    push @data, $_;
  }
  #print ">> (end)\n" if OUT_DBG;  
  #my $size = @data;
  #print ":: request_out: $. blocks read, $size stored\n" if STAT_DBG;  
  @data;
}

sub request_lines ( @ ) {
  local $/ = "\n";
  request_out(@_);
}

sub request_para ( @ ) {
  local $/ = "";
  request_out(@_);
}

sub request_for_lines ( $@ ) {  
  my $cb = shift;
  local $/ = "\n";
  request_foreach($cb, @_);
}

sub request_for_para ( $@ ) {
  my $cb = shift;
  local $/ = "";
  request_foreach($cb, @_);
}

sub messages () {
  my ($data) = request_lines 'stat';
  (split ' ', $data)[0];
}

my @HEADERS = qw( from to cc subject date x-spam-score );
my $HEADER_RE = '^(?i:' . join('|', map lc, @HEADERS) . '):';
$HEADER_RE = qr/$HEADER_RE/;

my @to_del;

my $msgs = messages;
my ($scanned, $unscanned) = (0, 0);

$START = 1 unless defined $START;
$START < 1
  and die "Starting message $START is invalid.\n" . USAGE;
$START > $msgs
  and die "Starting message $START is beyond the last ($msgs).\n" . USAGE;

$END = $msgs unless defined $END;
$END < $START
  and die "Ending message $END is before starting $START.\n" . USAGE;
$END > $msgs
  and die "Ending message $END is beyond the last ($msgs).\n" . USAGE;

sub score2key ( $ ) {
  my ($score) = @_;
  $score < 0         and return -1;
  $score >= HIST_MAX and return HIST_MAX;
  sprintf "%1d", int($score);
}
sub key2label ( $ ) {
  my ($key) = @_;
  $key == -1       and return         '< 0';
  $key == HIST_MAX and return sprintf '>=%1d', HIST_MAX;
  '  ' . $key;
}
my (%hist) = map +($_ => 0), -1..HIST_MAX;
my (%hist_del) = %hist;

my $need_nl;
for (my $first = $START;  $first <= $END;  $first += HEADER_BLOCK) {
  my $last = $first + HEADER_BLOCK - 1;
  $last > $END and $last = $END;

  print( (($first - $START) % HEADER_LABEL)
	 ? "." : $first );
  $need_nl = 1;

  my $N = $first-1;
  request_for_para sub {
    ++$N;
    my ($score) = ($_ =~ /^X-Spam-Score: (-?\d+(?:\.\d+)?)/mi)
      or ++$unscanned, return;
    ++$scanned;
    my $key = score2key $score;
    ++$hist{$key};
    (!defined $MAXSCORE or $score < $MAXSCORE) and return;

    if ($SHOW_INFO) {
      print "\n" if $need_nl;  $need_nl = 0;
      my $desc = join '', grep(/$HEADER_RE/, split /(?<=\n)(?!\s)/, $_);
      $desc =~ s/^/$N:/gm;
      print $desc, "\n";
    }

    $DELETE or return;
    ++$hist_del{$key};
    push @to_del, $N;
  }, map "top $_", $first..$last;
}
print "\n" if $need_nl;  $need_nl = 0;
print "$scanned messages were scanned for spam, $unscanned unscanned\n";

if ($HISTOGRAM) {
  for my $key (sort {$a <=> $b} keys %hist) {
    printf "  score %s: %6d messages", key2label($key), $hist{$key};
    printf ", %d left", $hist{$key}-$hist_del{$key} if $hist_del{$key};
    print "\n";
  }
  print "\n";
}

if ($DELETE) {
  if (! @to_del) {
    print "No messages were selected for deletion.\n";
  } else {
    my $num_del = 0+@to_del;
    print "Processing a total of $num_del deletions...\n";
    @to_del = sort {$b <=> $a} @to_del;
    #@to_del = reverse @to_del;
    while (my @d = splice @to_del, 0, DELETE_BLOCK) {
      $num_del = 0+@d;
      print "  processing $num_del deletions ($d[0]-$d[-1] of $msgs)...\n";
      #print "would delete:\n", map "  dele $_\n", @d;
      request_foreach sub { print }, map "dele $_", @d;
    }
    print "...done!\n";
  }
}