#!/usr/bin/perl

use strict;
use warnings;
use Encode qw/encode/;
use HTML::TreeBuilder;
use Text::Wrap;
use WWW::Mechanize;
use charnames ':full';

# configuration {{{
# base url of forum
use constant BASE_URL => 'http://www.welt-pergon.de/forum/';
# where to send mails
use constant MAILADDR => 'pergon@das-mehdorn.de';
# list of accounts to check
my %accounts = (
    'Accountname'  => {
        password => 'Mein Passwort',
        # PMs nach Konvertierung loeschen
        remove   => 1,
    },
    'weiterer Accountname' => {
        password => 'noch ein Passwort',
        # PMs liegenlassen
        remove   => 0,
    },
);
# }}}

sub handle_account { # {{{
    my ($user, $cfg) = @_;

    my $pass   = $cfg->{password};
    my $remove = $cfg->{remove};

    my $mech = WWW::Mechanize->new(
        autocheck   => 1,
        stack_depth => 1,
    );
    $mech->agent_alias('Linux Mozilla');
    push @{ $mech->requests_redirectable }, 'POST';

    # get main page and follow to login page for PMs
    $mech->get(BASE_URL);
    $mech->follow_link(text_regex => qr{private Nachricht}o);

    # log in
    my $res = $mech->submit_form(
        with_fields => {
            username => $user,
            password => $pass,
        },
        button   => 'login',
    );

    # simple check for success
    die "Wrong username or password"
        if $res->decoded_content() =~ m{falsches Pa..?wort}o;
    # no longer needed
    undef $res;

    die "Something strange happened after login; no logout button found"
        unless $mech->find_link(text_regex => qr{Logout}o);

    # get links to all PMs
    my $count = 0;
    my @pms = $mech->find_all_links(class => 'topictitle');
    foreach my $link (@pms) {
        # parse each PM
        parse_pm($mech, $link, $remove);
        $count++;
    }
    print "Found $count messages for $user\n";

    die "Error on logout; no logout button found"
        unless $mech->follow_link(text_regex => qr{Logout}o);
} # }}}

sub parse_pm { # {{{
    my ($mech, $link, $remove) = @_;

    my $res = $mech->get($link->url_abs());

    # prepare content for parsing
    my $html = HTML::TreeBuilder->new_from_content(
        $res->decoded_content
    );
    $html->elementify();
    $html->normalize_content();

    # find the table with the message itself
    my $msg = $html->look_down(
        '_tag', 'table', 'class', 'forumline'
    );

    # get message headers (some will be used as mail header)
    my @headers = $msg->look_down(
        '_tag', 'td', 'class', 'row2', 'align', undef
    );
    # FIXME: maybe %headers = map is ugly
    my %headers = map { $_->as_text() } @headers;

    # get message text block(s)
    my @texts = $html->look_down(
        '_tag', 'span', 'class', 'postbody'
    );
    unless (@texts) {
        warn 'No message text found for '. $link->url_abs();
        return;
    }
    map {
        $_ = $_->as_HTML();
        $_ =~ s{<span class="postbody">(.*)</span>}{$1}smog;
    } @texts;
    my $text = join("\n", @texts);

    # fix umlauts etc.
    $text =~ s{&(.)uml;}{$1e}smog;
    $text =~ s{&szlig;}{ss}smog;
    # pre-format text for mail
    my @paras = split(m{<br />}o, $text);
    $Text::Wrap::columns = 66;
    $text = fill('', '', @paras);

    # get e-mail address (if activated by user)
    my $addr = undef;
    my $canmail = $mech->find_link(text_regex => qr{E-Mail senden}o);
    if ($canmail) {
        $addr = $canmail->url_abs();
        $addr =~ s{^mailto:}{}o;
    };

    # forget about the tree
    $html->delete();

    #print send_mail(\%headers, $text, $addr) ."\n";
    if (send_mail(\%headers, $text, $addr)) {
        if ($remove) {
            # delete message
            $res = $mech->submit_form(
                button => 'delete'
            );
            $mech->submit_form(
                button => 'confirm'
            );
        };
    };
} # }}}

sub send_mail { # {{{
    my ($headers, $text, $addr) = @_;

    # prepare data
    $addr = 'dummy@example.invalid' unless $addr;
    foreach my $key (keys %$headers) {
        $headers->{$key} = encode('ascii', $headers->{$key}, \&asciify);
    }

    my $mail;
    unless (open($mail, '|/usr/sbin/sendmail -oi -t')) {
        warn "Can't fork for sendmail: $!\n";
        return undef;
    }

    # header
    print $mail 'From: '.    $headers->{'Von:'} .' <'. $addr    .">\n";
    print $mail 'To: '.      $headers->{'An:'}  .' <'. MAILADDR .">\n";
    print $mail 'Subject: '. $headers->{'Titel:'} ."\n";
    print $mail "MIME-Version: 1.0\n";
    print $mail "Content-Type: text/plain; charset=utf-8\n";
    print $mail "Content-Transfer-Encoding: 8bit\n";
    print $mail "\n";

    # body
    print $mail encode("UTF-8", $text);

    unless (close($mail)) {
        warn "sendmail didn't close nicely";
        return undef;
    }

    return 1;
} # }}}

sub asciify { # {{{
    my ($ord) = @_;
    my $name = charnames::viacode($ord);
    my ($main, $with) = $name =~ m{^(.+)\sWITH\s(.*)}o;
    if (defined $with) {
        #print "dia\n" if $with eq 'DIAERESIS';
        if (($with eq 'DIAERESIS') and ($main =~ m{\b[aou]\b}oi)) {
            return chr(charnames::vianame($main)) ."e";
        }
        return chr(charnames::vianame($main));
    }
    return "ss" if ($name eq 'LATIN SMALL LETTER SHARP S');
    return "?";
} # }}}

foreach my $user (keys %accounts) {
    handle_account($user, $accounts{$user});
}
