#!/afs/athena/contrib/perl5/perl
# analyze bert's Gnus mail group hierarchy
use warnings;
use strict;

### config

my ($HOME, $ROOT, $newsrc, $newslisp, $gnuscfg);
$HOME     = shift @ARGV                    if @ARGV;
$HOME     = $ENV{HOME}                     unless defined $HOME;
$HOME     = '.'                            unless defined $HOME;
$gnuscfg  = shift @ARGV                    if @ARGV;
$gnuscfg  = "$HOME/elisp/21/gnus-setup.el" unless $gnuscfg;
$ROOT     = $HOME;
$ROOT     = "$ROOT/Mail"                   unless -e "$ROOT/active";
$newsrc   = shift @ARGV                    if @ARGV;
$newsrc   = "$ROOT/.newsrc"                unless $newsrc;
$newslisp = shift @ARGV                    if @ARGV;
$newslisp = "$ROOT/.newsrc.eld"            unless $newslisp;

our (%perlify) = map +($_, 1),
	   qw( gnus-newsrc-alist gnus-topic-topology gnus-topic-alist );

### helpers: conversion to Perl data structures

sub el2pl_deslash ($) {
  my ($arg) = @_;
  $arg =~ s/\\(.)/$1/g;
  $arg;
}

sub el2pl_split ($);
sub el2pl_split ($) {
  my ($arg) = @_;
  my ($str, $rest);

  # integer
  ($str, $rest) = ($arg =~ /^([-+]?\d+)\s*(.*?)$/)
    and return ($str, $rest);

  # string
  if ($arg =~ /^\'?\"/) {
    ($str, $rest) = ($arg =~ /^\'?"((?:\\.|[^\"\\])*)"\s*(.*?)$/)
      and return (el2pl_deslash($str), $rest);
    die "Unterminated string in '$arg'\n";
  }

  # nil and t
  ($rest) = ($arg =~ /^\'?nil\b\s*(.*?)$/)
    and return (undef, $rest);
  ($rest) = ($arg =~ /^\'?t\b\s*(.*?)$/)
    and return (1, $rest);

  # list
  $rest = $arg;
  if ($rest =~ s/^\'?\(\s*//) {
    my @list;
    while (! ($rest =~ s/^\)\s*//)) {
      $rest =~ s/^\.\s+//;  # treat a cons '(a . b) as list '(a b)
      ($str, $rest) = el2pl_split $rest;
      push @list, $str;
      length $rest or die "Unterminated list in '$arg', at '$rest'\n";
    }
    return (\@list, $rest);
  }

  # symbols (and operators, sigh)
  ($str, $rest) = ($arg =~ /^\'?([-+><=\w]+)\s*(.*?)$/)
    and return ($str, $rest);

  die "Unknown argument type in '$arg'";
}

sub el2pl ($) {
  my ($arg) = @_;
  my ($val, $rest) = el2pl_split $arg;
  defined $rest and length $rest
    and die "Extra characters at the end of '$arg'\n";
  $val;
}

### helpers: alists

sub list2alist ($) {
  my ($list) = @_;
  ref $list eq 'ARRAY' or die "Bad alist $list!\n";
  +{ map +(shift(@$_), $_), @$list };
}

### read and mangle stuff

our (%eld, %groups, @dests);
{
  open my $NEWSLISP, '<', $newslisp
    or die "open($newslisp): $!";
  warn "Reading $newslisp...\n";
  while (<$NEWSLISP>) {
    /^;/ and next;
    my ($sym, $val) = /^\(setq (\S+) (.*)\)$/
      or die "invalid .newsrc.eld line: $_";
    $eld{$sym} = $val;
  }
}

{
  warn "Processing data from $newslisp...\n";
  for my $sym (keys %eld) {
    if ($perlify{$sym}) {
      my $val = el2pl $eld{$sym};
      $val = list2alist $val if $sym =~ /-alist$/;
      $eld{$sym} = $val;
    }
  }
  $groups{$_} = 1 foreach keys %{$eld{'gnus-newsrc-alist'}};
}

{
  open my $NEWSRC, '<', $newsrc
    or die "open($newsrc): $!";
  warn "Reading $newsrc...\n";
  while (<$NEWSRC>) {
    my ($name, $delim, $rest) = /^(\S+)([:!])(?:\s+(.*?))$/
      or die "invalid .newsrc line: $_";
    warn "group $name is marked as unsubscribed!\n" if $delim ne ':';
    exists $groups{$name}
      or warn "group $name exists only in .newsrc!\n";
    $groups{$name} = 2;
  }
}

delete $groups{$_} foreach grep /^nndraft:/, keys %groups;

$groups{$_} == 2 or warn "group $_ exists only in .newsrc.eld!\n"
    foreach sort keys %groups;

{
  open my $GNUS, '<', $gnuscfg
    or die "open($gnuscfg): $!";
  warn "Reading $gnuscfg...\n";
  while (<$GNUS>) {
    next unless /^\(setq nnmail-split-fancy/../^; ---END---/;
    s/\s*;.*//;
    s/(?=\W)/\\/g, s/\\{4}\d/.*/g, push(@dests, $_) foreach /"([^"]+)"\)/g;
  }
}

$_ = qr/^$_$/ foreach @dests;

### mangle the topology list

our (%t_isa, %g_isa);

sub topologize ($@);
sub topologize ($@) {
  my ($top, @hier) = @_;
  my $name = $top->[0][0];
  $t_isa{$name}{$_} = 1 foreach ($name, @hier);
  topologize $top->[$_], $name, @hier foreach 1..$#$top;
}  

warn "Handling topology...\n";
topologize $eld{'gnus-topic-topology'};
foreach my $topic (keys %{$eld{'gnus-topic-alist'}}) {
  $g_isa{$_} = $t_isa{$topic} foreach @{$eld{'gnus-topic-alist'}{$topic}};
}

### final analysis

warn "Handling group usage...\n";
our (%used);
GROUP:
for my $group (sort keys %groups) {
  $used{$group} = 1;
  for my $re (@dests) {
    $group =~ $re and next GROUP;
  }
  $used{$group} = 0;
}

for my $group (sort keys %used) {
  next            if $group eq 'bogus';
  next            if $g_isa{$group}{'spam'};
  my $expect = 1;
  $expect = 0     if $g_isa{$group}{'Old'};
  $expect = 0     if $g_isa{$group}{'pulled'};
  $expect = 0     if $group =~ /\.old$/;
  if ($expect != $used{$group}) {
    print( ($expect ? 'UNUSED: ' : 'USED:   '), $group, "\n" );
  }
}