#! /usr/bin/perl -w
#
# Read the latest mailing list info and load it into the database.
# Input is either ASCII text formatted like:
#
# or XML like:
#
# <mailing-lists>
#  <site>
#   <name>sitename</name>
#   <asof>timestamp</asof>
#   <list>
#    <name>listname</name>
#    <moderator>eddress</moderator>...
#    <subscribers>int</subscribers>
#    <digest-subscribers>int</digest-subscribers>
#    <info>encoded-info</info>     <!-- optional -->
#    <messages>int</messages>      <!-- optional -->
#   </list>
#   <list>...
#  </site>
# </mailing-lists>
#

use strict;
use Data::Dumper;
use DBI;
use DBD::mysql;
use Digest::MD5 qw(md5_hex);
use Getopt::Long;
use Symbol;
use XML::LibXML::Common qw(:encoding);
use XML::Simple qw(:strict);

my $fh = select(STDOUT);
$| = 1;
select(STDERR);
$| = 1;
select($fh);

my $dsn = "DBI:$ENV{PULSE_DBMS}"
    . ":database=$ENV{PULSE_DB_NAME}"
    . ":host=$ENV{PULSE_DB_HOST}";
my $dbx = DBI->connect($dsn, $ENV{PULSE_DB_USER}, $ENV{PULSE_DB_PASSWORD},
                       {
                        RaiseError => 1,
                        PrintError => 1,
                       });

Getopt::Long::Configure('bundling');
Getopt::Long::Configure('auto_abbrev');
Getopt::Long::Configure('pass_through');

my $debug = 0;
my $dry_run = 0;
my $infile = '-';

GetOptions(
           'd|debug+'        => \$debug,
           'f|input-file=s'  => \$infile,
           'n|no-action'     => \$dry_run,
          );

my $asof = '1980-01-01';
my $sql;
my $status;
my $dbq;
my $xml = 0;
my $linenum = 0;
my $xp = new XML::Simple;
my @lines;
my $lastdomain;
my $domain;
my $list;
my $subscribers;
my $digesters;
my $moderators;

$infile = 'STDIN' if ($infile eq '-');
debug(2, "Reading from $infile");
my $ifh;
if ($infile ne 'STDIN') {
    $ifh = gensym();
    open($ifh, '<' . $infile) || die("Error opening '$infile': $!");
}
else {
    $ifh = \*STDIN;
}

while (my $line = <$ifh>) {
    $line =~ s§[\r\n\s]+$§§g;
    chomp($line);
    next if (! $line);
    if ($line =~ /<\?xml/) {
        debug(2, 'XML-format detected');
        $xml++;
        @lines = <$ifh>;
        chomp(@lines);
        unshift(@lines, $line);
        next;
    }
    debug(5, "line='$line'");
    ($list, $subscribers, $digesters, $moderators) = split(m/\|/, $line);
    $list =~ m§(.*)\@(.*)$§;
    $list = $1;
    $domain = $2;
    $subscribers =~ s/\s+//g;
    $digesters =~ s/\s+//g;
    $digesters = -1 if ($digesters =~ /none/i);
    $moderators =~ s/\s+/,/g;
    if ($domain ne $lastdomain) {
        push(@lines, ' </site>') if ($lastdomain);
        push(@lines, ' <site>');
        push(@lines, "  <name>$domain</name>");
        $lastdomain = $domain;
    }
    push(@lines,
         '  <list>',
         "   <name>$list</name>",
         "   <moderator>$moderators</moderator>",
         "   <subscribers>$subscribers</subscribers>",
         "   <digest-subscribers>$digesters</digest-subscribers>",
         "  </list>");
}
close($ifh) if ($ifh != \*STDIN);

if (! $xml) {
    push(@lines, ' </site>') if ($domain);
    push(@lines, "</mailing-lists>\n");
}
#
# Remove the '<?xml' processing instruction (??)
#
shift(@lines);
$xml = join("\n", @lines);
debug('Parsing XML');
my $xml_parsed = $xp->XMLin($xml,
                            forcearray => 1,
                            keyattr => [ ],
                           );
debug('XML parsed');
#print Dumper($xml_parsed);

$asof = $xml_parsed->{asof}->[0];
debug(2, "AS-OF determined as '$asof'");
$sql = ('INSERT INTO loadinfo '
        . "SET asof='$asof' ");
my $oldprinterr = $dbx->{PrintError};
$dbx->{PrintError} = 0;
if (! $dry_run) {
    $dbq = $dbx->prepare($sql);
    $status = $dbq->execute();
}
$dbx->{PrintError} = $oldprinterr;

for (my $i = 0; $i <= $#{$xml_parsed->{site}}; $i++) {
    my $site = $xml_parsed->{site}->[$i];
    debug(3, $site->{name}->[0]);
    for (my $j = 0; $j <= $#{$site->{list}}; $j++) {
        my @dbargs;
        my $dmsg;
        my $list = $site->{list}->[$j];
        my $info_xid = 0;
        $status = $list->{status}->[0];
        $sql = "INSERT INTO list SET list=?, asof=?, domain=?, "
            . "status=?";
        my $domain_name = $site->{name}->[0];
        my $list_name = $list->{name}->[0] . '@' . $domain_name;
        push(@dbargs, $list_name, $asof, $domain_name, $status);
        $dmsg = $sql . " (list='$list_name', asof='$asof', domain='$domain_name', status='$status') ";
        if (defined($list->{subscribers})) {
            $sql .= ', count=?';
            $dmsg .= ', count=?';
            push(@dbargs, $list->{subscribers}->[0]);
            $dmsg .= " (count='" . $list->{subscribers}->[0] . "') ";
        }
        if (defined($list->{'digest-subscribers'})) {
            $sql .= ', dcount=?';
            $dmsg .= ', dcount=?';
            push(@dbargs, $list->{'digest-subscribers'}->[0]);
            $dmsg .= " (dcount='" . $list->{'digest-subscribers'}->[0] . "') ";
        }
        if (defined($list->{messages})) {
            $sql .= ', posts=?';
            $dmsg .= ', posts=?';
            push(@dbargs, $list->{messages}->[0]);
            $dmsg .= " (posts='" . $list->{messages}->[0] . "') ";
        }
        if (defined($list->{moderators})) {
            $sql .= ', moderators=?';
            $dmsg .= ', moderators=?';
            push(@dbargs, $list->{moderators}->[0]);
            $dmsg .= " (moderators='" . $list->{moderators}->[0] . "') ";
        }
        if (defined($list->{info})) {
            debug(5, "Decoding info from UTF8: [['" . $list->{info}->[0] . "']]");
            my $info = decodeFromUTF8('ISO-8859-1', $list->{info}->[0]);
            my $sum = md5_hex($info);
            my $lsql = 'SELECT xid FROM info_text WHERE sum=?';
            if (! $dry_run) {
                $dbq = $dbx->prepare($lsql);
                $dbq->execute($sum);
                if ($dbq->rows() == 0) {
                    debug(3, 'Adding a new list info record');
                    my $l2sql = 'INSERT INTO info_text SET sum=?, info=?';
                    $dbq = $dbx->prepare($l2sql);
                    $dbq->execute($sum, $info);
                    $dbq = $dbx->prepare($lsql);
                    $dbq->execute($sum);
                }
                my $hash = $dbq->fetchrow_hashref();
                $info_xid = $hash->{xid};
            }
        }
        if ($info_xid) {
            $sql .= ', info=?';
            push(@dbargs, $info_xid);
        }
        debug(5, "SQL='$dmsg'");
        if (! $dry_run) {
            $dbq = $dbx->prepare($sql);
            $dbq->execute(@dbargs);
        }
        debug(3, '  ' . $list->{name}->[0]);
    }
}

if (! $dry_run) {
    $dbx->disconnect();
}

exit(0);

sub debug {
    my $text = shift;
    my $level = 1;
    if ($text =~ /^\d+$/) {
        $level = $text;
        $text = shift;
    }
    if ($debug >= $level) {
        chomp($text);
        print STDERR "DEBUG: $text\n";
    }
}


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