#! /usr/bin/perl -w
#
# Read the Apache mailing list information, load it into a DOM
# structure, and emit it as XML.
#
# aplists.pl [options] [list-parent-directory]
#
# -h    help/usage
# -c    count messages in last 24 hours with find(1)
# -C    count messages in last 24 hours using EZMLM message counters
# -o    include public lists (subscription not moderated)
# -O    don't include public lists
# -p    include private lists (subscription moderated)
# -P    don't include private lists
# -a    include both public and private lists
# -s    include subscribers
# -S    don't include subscribers
# -u    record list message counters in SDBM file
# -x    Generate output in XML format
#
# Output format is one line per list:
#  <site>:<listname>[=<info-file>][,<listname>[=info-file]...
#
# or XML:
#  <mailing-lists>
#   <asof>yyyy-mm-dd</asof>
#   <site>
#    <name>sitename</name>
#    <list>
#     <name>listname</name>
#     <status>unknown|public|private</status>
#     <subscribers>int</subscribers>
#     <digest-subscribers>int</digest-subscribers>
#     <info>encoded-info</info>
#     <messages>int</messages>                <!-- optional -->
#     <subscribers>                           <!-- based on -s -->
#      <eddress><![CDATA[eddress]]></eddress> <!--   : -->
#          :                                  <!--   : -->
#     </subscribers>                          <!--   : -->
#    </list>
#    <list>...
#   </site>
#     :
#  </mailing-lists>
#
use strict;
use Carp;
use Data::Dumper;
use Date::Manip qw( ParseDateString );
use Getopt::Long;
use POSIX;
use Symbol;
use XML::LibXML::Common qw(:encoding);

{
    package Pulse;

    use Carp;
    use Data::Dumper;
    use Fcntl;
    use POSIX;
    use SDBM_File;

    our $DebugLevel = 1;

    sub accessors {

        my ($class, @fields) = @_;
        return unless (@fields);
        my $caller = caller();

        #
        # Build the code we're going to eval for the caller
        # Do the fields call for the calling package
        #
        my $eval = "package $caller;\n"
            . "use fields qw( " . join(' ', @fields) . ");\n";

        # Generate convenient accessor methods
        foreach my $field (@fields) {
            local ($|);
            $| = 1;
            $eval .= "sub $field : lvalue { \$_[0]->{$field} }\n"
                unless ($caller->can($field));
        }

        # Eval the code we prepared
        eval($eval);

        # $@ holds possible eval errors
        $@ and die "Error setting members for $caller: $@";
    }

    sub mkpath {
        my $self = shift;
        return join('/', $self->path, @_);
    }

    sub debug {
        shift if ((ref($_[0])) || ($_[0] eq __PACKAGE__));
        my $level = 1;
        if ($_[0] =~ /^\d+$/) {
            $level = shift;
        }
        if ($Pulse::DebugLevel >= $level) {
            print "debug[$level]: " . join(' ', @_) . "\n";
        }
    }

    #
    # Constructor
    #
    sub new {
        my ($class, $path, @args) = @_;
        my $self = bless({}, ref($class) || $class);
        $self->{options} = (ref($args[0]) eq 'HASH') ? $args[0] : { @_ };
        $self->accessors(qw(
                               asof
                               asofISO
                               counterDB
                               domains
                               eddresses
                               path
                          ));
        $self->domains = {};
        $self->eddresses = {};
        $self->path = $path;
        $self->asof = strftime('%Y-%m-%d %H:%M', localtime());
        $self->asofISO = strftime('%Y-%m-%dT%H:00', localtime());
        $self->counterDB = {};
        tie(%{$self->counterDB},
            'SDBM_File',
            $self->mkpath('pulse-message-counts.sdbm'),
            O_RDWR | O_CREAT,
            0640);
        return $self;
    }

    sub DESTROY {
#        untie(%{$self->counterDB}) if (ref($self->counterDB) eq 'HASH');
    }

    sub registerDomain {
        my $self = shift;
        my @added = ();
        for my $domain (@_) {
            my $dobject;
            my $dname = ref($domain) ? $domain->name : $domain;
            unless (exists($self->domains->{$dname})) {
                $dobject = ref($domain)
                    ? $domain
                    : Domain->new($self, $dname, $self->{options});
                $self->domains->{$dname} = $dobject;
            }
            push(@added, $dobject);
        }
        return \@added;
    }

    sub registerEddress {
        my $self = shift;
        my @added = ();
        for my $item (@_) {
            my $name = ref($item) ? $item->name : $item;
            unless (exists($self->eddresses->{$name})) {
                my $object = ref($item)
                    ? $item
                    : Pulse::Eddress->new($name, $self->{options});
                $self->eddresses->{$name} = $object;
            }
            push(@added, $self->eddresses->{$name});
        }
        return \@added;
    }

    sub utf8_safe {
        my ($class, $input) = @_;
        my %table;
        my $ichar;
        for (my $i = 0; $i <= 0xFF; $i++) {
            $ichar = chr($i);
            if (($i == 0x09)
                || ($i == 0x0A)
                || ($i == 0x0D)
                || (($i >= 0x20)
                    && ($i <= 0x7F))) {
                $ichar = chr($i);
#                if ($ichar eq '<') {
#                    $table{$ichar} = '&lt;';
#                }
#                elsif ($ichar eq '>') {
#                    $table{$ichar} = '&gt;';
#                }
#                elsif ($ichar eq '&') {
#                    $table{$ichar} = '&amp;';
#                }
                next;
            }
            if (($i < 0x7F)
                || (($i >= 0x7F) && ($i <= 0x84))
                || (($i >= 0x86) && ($i <= 0x9F))) {
                $table{$ichar} = '*';
            }
            else {
                $table{$ichar} = sprintf('&#x%02x;', $i);
            }
        }
        my $output = '';
        for (my $i = 0; $i < length($input); $i++) {
            my $ichar = substr($input, $i, 1);
            if (defined($table{$ichar})) {
                $output .= $table{$ichar};
            }
            else {
                $output .= $ichar;
            }
        }
        return $output;
    }
}

{
    package Domain;

    use Carp;
    use Data::Dumper;

    our @ISA = qw( Pulse );

    #
    # Constructor
    #
    sub new {
        my ($class, $pulse, $domain, @args) = @_;
        my $self = bless({}, ref($class) || $class);
        $self->{options} = (ref($args[0]) eq 'HASH') ? $args[0] : { @_ };
        $self->accessors qw( name pulse lists path );
        $self->name = $domain;
        $self->pulse = $pulse;
        $self->lists = {};
        $self->path = $pulse->mkpath($domain);
        return $self;
    }

    #
    # Destructor
    #
    sub DESTROY {
    }

    sub registerList {
        my $self = shift;
        my @added = ();
        for my $item (@_) {
            my $name = ref($item) ? $item->name : $item;
            unless (exists($self->lists->{$name})) {
                my $object = ref($item)
                    ? $item
                    : Domain::List->new($self, $name, $self->{options});
                $self->lists->{$name} = $object;
            }
            push(@added, $self->lists->{$name});
        }
        return \@added;
    }

}

{
    package Domain::List;
    our @ISA = qw( Domain );

    use Carp;
    use Data::Dumper;
    use SDBM_File;
    use Symbol;

    #
    # Constructor
    #
    sub new {
        my ($class, $domain, $list, @args) = @_;
        my $self = bless({}, ref($class) || $class);
        $self->accessors(qw(
                               name
                               archived
                               digested
                               digesters
                               domain
                               info
                               messageCount
                               messageInterval
                               moderators
                               path
                               pulse
                               public
                               subscribers
                          ));
        $self->{options} = (ref($args[0]) eq 'HASH') ? $args[0] : { @_ };
        $self->messageInterval = $self->{options}->{CountInterval} || 1;
        ($list, undef) = split(/\@/, $list, 1);
        croak(__PACKAGE__ . ' constructor requires a Domain object')
            unless (ref($domain) eq 'Domain');
        $self->name = $list;
        $self->domain = $domain;
        $self->pulse = $domain->pulse;
        $self->path = $domain->mkpath($list);
        my $cfh = gensym();
        my $cfgpath = $self->mkpath('config');
        open($cfh, "< $cfgpath")
            or croak("Can't opendir($cfgpath): $!");
        my @cfglines = <$cfh>;
        close($cfh);
        @cfglines = grep(/^F:/, @cfglines);
        croak("Can't find F: config line in $cfgpath")
            unless (@cfglines == 1);
        $self->public = $cfglines[0] =~ /S/;
        $self->archived = $cfglines[0] =~ /a/;
        $self->digested = $cfglines[0] =~ /d/;
        if ($self->{options}->{IncludeInfo}) {
            my $ifile = $self->mkpath('text/info');
            my $info;
            if (-r $ifile) {
                open($cfh, "< $ifile")
                    or croak("Can't open $ifile: $!");
                my @info = <$cfh>;
                close($cfh);
                $info = join('', @info);
                $info = Pulse->utf8_safe($info);
            }
            else {
                $info = "No information has been provided\n";
            }
            $self->info = $info;
        }
        my @eddresses;
        my $cmd;

        if ($self->{options}->{IncludeSubscribers}) {
            $self->subscribers = {};
            $cmd = 'ezmlm-list -N ' . $self->path;
            open($cfh, "$cmd |")
                or croak("Unable to open pipe for '$cmd': $!");
            @eddresses = <$cfh>;
            close($cfh);
            chomp(@eddresses);
            for my $eddress (@eddresses) {
                $eddress = Pulse->utf8_safe($eddress);
                $self->registerSubscriber($eddress);
            }
            $self->debug(4,
                         'Loaded '
                         . scalar(keys(%{$self->subscribers}))
                         . ' subscribers');

            $self->moderators = {};
            $cmd = 'ezmlm-list -N ' . $self->mkpath('mod');
            open($cfh, "$cmd |")
                or croak("Unable to open pipe for '$cmd': $!");
            @eddresses = <$cfh>;
            close($cfh);
            chomp(@eddresses);
            for my $eddress (@eddresses) {
                $eddress = Pulse->utf8_safe($eddress);
                $self->registerModerator($eddress);
            }
            $self->debug(4,
                         'Loaded '
                         . scalar(keys(%{$self->moderators}))
                         . ' moderators');

            $self->digesters = {};
            if ($self->digested) {
                $cmd = 'ezmlm-list -N ' . $self->mkpath('digest');
                open($cfh, "$cmd |")
                    or croak("Unable to open pipe for '$cmd': $!");
                @eddresses = <$cfh>;
                close($cfh);
                chomp(@eddresses);
                for my $eddress (@eddresses) {
                    $eddress = Pulse->utf8_safe($eddress);
                    $self->registerDigester($eddress);
                }
                $self->debug(4, 'Loaded ' . scalar(keys(%{$self->digesters}))
                             . ' digest subscribers');
            }
        }
        my $file = $self->mkpath('num');
        my $key1 = $self->fullname . ':';
        my $key = $key1 . $self->pulse->asofISO;
        my @stamps = grep(/^$key1/, keys(%{$self->pulse->counterDB}));
        Pulse->debug(4, scalar(@stamps) . ' recorded counters');
        my $counters;
        if (-f $file) {
            open($cfh, "< $file")
                or croak("Can't open $file: $!");
            $counters = <$cfh>;
            close($cfh);
            chomp($counters);
            if ($self->{options}->{UpdateCounters}) {
                $self->pulse->counterDB->{$key} = $counters;
                if (my $when = $self->{options}->{WeedDate}) {
                    my $threshold = $key1 . $when;
                    my @doomed = grep({ $_ lt $threshold } @stamps);
                    if (@doomed) {
                        Pulse->debug(4,
                                     scalar(@doomed)
                                     . ' recorded counters to weed');
                        delete(@{$self->pulse->counterDB}{(@doomed)});
                    }
                }
            }
        }
        if ($self->{options}->{UseCounters}) {
            my $threshold = strftime('%Y-%m-%dT%H:%M',
                                     localtime() - 24 * 60 * 60);
            $threshold = $self->fullname . ':' . $threshold;
            my @earlier = grep( { $_ le $threshold } @stamps);
            $threshold = strftime('%Y-%m-%dT%H:%M',
                                  localtime() - 48 * 60 * 60);
            my ($stamp, @trash) = sort(grep( { $_ le $threshold } @stamps));
            if ($stamp) {
                my ($now) = split(/:/, $self->pulse->counterDB->{$key});
                my ($then) = split(/:/, $self->pulse->counterDB->{$stamp});
                $self->messageCount = int($now) - int($then);
            }
        }
        elsif ($self->{options}->{CountMessages}) {
            $self->countMessages($self->messageInterval);
        }
        return $self;
    }

    sub fullname {
        my $self = shift;
        return $self->name . '@' . $self->domain->name;
    }

    sub countMessages {
        my $self = shift;
        my $interval = $_[0] || $self->{options}->{CountInterval};
        $self->messageCount = -1;
        if ($self->archived) {
            $self->debug(4, "Locating messages from last $interval day(s)");
            my $cmd = sprintf('find %s/archive -mtime -%d -type f -name \[0-9\]*'
                              . ' | wc -l |',
                              $self->path, $interval);
            my $cfh = gensym();
            open($cfh, $cmd)
                or croak("Unable to execute '$cmd': $!");
            my $msgs = <$cfh>;
            close($cfh);
            $msgs =~ /(\d+)/;
            $self->messageCount = $1;
        }
    }

    sub registerSubscriber {
        my $self = shift;
        my @added = ();
        for my $item (@_) {
            my $name = ref($item) ? $item->name : $item;
            unless (exists($self->subscribers->{$name})) {
                my $object = ref($item)
                    ? $item
                    : Pulse::Eddress->new($name, $self->{options});
                $self->domain->pulse->registerEddress($object);
                $self->subscribers->{$name} = $object;
            }
            push(@added, $self->subscribers->{$name});
        }
        return \@added;
    }

    sub registerDigester {
        my $self = shift;
        my @added = ();
        for my $item (@_) {
            my $name = ref($item) ? $item->name : $item;
            unless (exists($self->digesters->{$name})) {
                my $object = ref($item)
                    ? $item
                    : Pulse::Eddress->new($name, $self->{options});
                $self->domain->pulse->registerEddress($object);
                $self->digesters->{$name} = $object;
            }
            push(@added, $self->digesters->{$name});
        }
        return \@added;
    }

    sub registerModerator {
        my $self = shift;
        my @added = ();
        for my $item (@_) {
            my $name = ref($item) ? $item->name : $item;
            unless (exists($self->moderators->{$name})) {
                my $object = ref($item)
                    ? $item
                    : Pulse::Eddress->new($name, $self->{options});
                $self->domain->pulse->registerEddress($object);
                $self->moderators->{$name} = $object;
            }
            push(@added, $self->moderators->{$name});
        }
        return \@added;
    }

}

{
    package Pulse::Eddress;

    use Carp;
    use Data::Dumper;

    our @ISA = qw( Pulse );

    #
    # Constructor
    #
    sub new {
        my ($class, $eddress, @args) = @_;
        my $self = bless({}, ref($class) || $class);
        $self->{options} = (ref($args[0]) eq 'HASH') ? $args[0] : { @_ };
        $self->accessors qw( name );
        $self->name = $eddress;
        return $self;
    }
}

package main;

my %options;
my $include_public = 1;
my $include_private = 0;
my $include_subscribers = 0;
my $use_xml = 0;
my $count = 0;
my $usemsgcounters = 0;
my $updatemsgcounters = 0;
my $debug = 0;
my $include_info = 0;
my $weed_date = '';
my $phandle = gensym();

Getopt::Long::Configure('bundling');
GetOptions(\%options,
           'all|a'   => sub { $include_public = $include_private = 1; },
           'count-message-files|c'       => \$count,
           'use-message-counters|C'      => \$usemsgcounters,
           'debug|d+'                    => \$debug,
           'help|h'                      => \&usage,
           'include-info|i'              => \$include_info,
           'include-public-lists|o'      => \$include_public,
           'noinclude-public-lists|O'    => sub { $include_public = 0; },
           'include-private-lists|p'     => \$include_private,
           'noinclude-private-lists|P'   => sub { $include_private = 0; },
           'include-subscribers|s'       => \$include_subscribers,
           'noinclude-subscribers|S'     => sub { $include_subscribers = 0; },
           'update-message-counters|u'   => \$updatemsgcounters,
           'weed-counters|w:s'           => \$weed_date,
           'x'   => \$use_xml,
           );
#
# No counting if we're not generating XML..
#
$count = 0 if ($count && (! $use_xml));
if ($weed_date) {
    ParseDateString($weed_date) =~ m/(\d{4})(\d{2})(\d{2})
                                     (\d{2}):?(\d{2}):?(\d{2})/x;
    $weed_date = sprintf('%04d-%02d-%02dT%02d:%02d', $1, $2, $3, $4, $5);
}

$Pulse::DebugLevel = $debug;
Pulse->debug('public              =', $include_public);
Pulse->debug('private             =', $include_private);
Pulse->debug('getInfo             =', $include_info);
Pulse->debug('subscribers         =', $include_subscribers);
Pulse->debug('countMessages       =', $count);
Pulse->debug('useMessageCounts    =', $usemsgcounters);
Pulse->debug('updateMessageCounts =', $updatemsgcounters);
Pulse->debug('weedDate            =', $weed_date);

my $TLD = $ARGV[0] || '/home/apmail/lists';

my $tlh = gensym();
my $slh = gensym();
my $pulse = Pulse->new($TLD,
                       {
                        CountMessages      => $count,
                        IncludeInfo        => $include_info,
                        IncludePrivate     => $include_private,
                        IncludePublic      => $include_public,
                        IncludeSubscribers => $include_subscribers,
                        UpdateCounters     => $updatemsgcounters,
                        UseCounters        => $usemsgcounters,
                        WeedDate           => $weed_date,
                       }
                      );
opendir($tlh, $TLD) or die("Can't opendir($TLD): $!");
my @tldirs = readdir($tlh);
closedir($tlh);

#
# @tldirs now has a list of all the sites.  Scan each one for the
# lists on that site.
#

for my $site (@tldirs) {
    my $domain = $pulse->registerDomain($site)
        unless (($site =~ /^(?:\.+|cvs)$/i)
                || (! -d "$TLD/$site"));
}
Pulse->debug(1, 'Domains loaded: ' . scalar(keys(%{$pulse->domains})));

my $listcount = 0;
for my $dname (sort(keys(%{$pulse->domains}))) {
    my $domain = $pulse->domains->{$dname};
    Pulse->debug(2, "Getting lists for $dname");
    opendir($slh, $domain->path)
        or die("Can't opendir(" . $domain->path . "): $!");
    my @sldirs = readdir($slh);
    closedir($slh);
    for my $ldir (sort(@sldirs)) {
        my $lpath = $domain->path . '/' . $ldir;
        next unless ((-d $lpath) && (-f "$lpath/config"));
        Pulse->debug(3, "Loading list $ldir\@" . $domain->name);
        my $list = $domain->registerList($ldir);
        $listcount++;
    }
}
Pulse->debug(1, scalar(keys(%{$pulse->eddresses})) . ' total eddresses');
Pulse->debug(1, $listcount . ' total lists');
Pulse->debug(1, 'Done loading data from filesystem');

if ($use_xml) {
    Pulse->debug(1, 'Building DOM structure');
    my $doc = XML::LibXML::Document->new();
    my $root = $doc->createElement('mailing-lists');
    $doc->setDocumentElement($root);

    my $domains = $pulse->domains;
    for my $dname (sort(keys(%{$domains}))) {
        my $domain = $domains->{$dname};
        my $domain_object = $doc->createElement('site');
        $root->appendChild($domain_object);
        Pulse->debug(2, "Adding domain $dname to DOM");
        my $object = $doc->createElement('name');
        $object->appendChild($doc->createTextNode($dname));
        $domain_object->appendChild($object);
        for my $lname (sort(keys(%{$domain->lists}))) {
            my $list = $domain->lists->{$lname};
            my $list_object = $doc->createElement('list');
            $domain_object->appendChild($list_object);
            Pulse->debug(3, "Adding list $lname\@$dname to DOM");
            $list_object->appendTextChild('name', $lname);
            $list_object->appendTextChild('status',
                                          ($list->public
                                           ? 'public'
                                           : 'private'));
            $object = $doc->createElement('info');
            my $cdata = $doc->createCDATASection($list->info || '');
            $object->appendChild($cdata);
            $list_object->appendChild($object);
        }
    }
    print $doc->toString(1);
}
#print Dumper([ keys(%{$pulse->{domainhash}}) ]);
exit;


__END__
my $list = Domain::List->new($domain, 'dev');
$domain->addList($list);
$list->addSubscriber('coar@apache.org','Ken@Coar.Org');
$list->addSubscriber('coar@apache.org','Ken@Coar.Org');
print Dumper($list);

#
# Local Variables:
# mode: cperl
# tab-width: 4
# indent-tabs-mode: nil
# End:
#
