#!/usr/bin/perl

use strict;
use warnings;
use Getopt::Long;

use LWP::UserAgent;

sub get_webpage { # {{{

    my $ua = LWP::UserAgent->new(
        agent => 'Mozilla/5.0 (X11; U; Linux i686; en-US) Gecko/2007121602'
    );

    my $res = 
        $ua->get('http://www.welt-pergon.de/index.php?modus=main&id=48');

    unless ($res->is_success()) {
        warn("HTTP GET failed!");
        return undef;
    }

    return $res->decoded_content;
} # }}}

sub get_player_list { # {{{

    my $page = get_webpage();
    return undef unless defined $page;

    # get time
    my ($time)   = $page =~ m/Es ist 0?([0-9]{1,2}:[0-9]{2}) .*Uhr/smo;
    #my ($uptime) = $page =~ m/Uhr.*Uptime.*> = 0?([0-9]{1,2}:[0-9]{2})/mo;
    my ($uptime) = $page =~ m/Uhr.*Uptime.*> = (.*:[0-9]{2})/mo;
    return if $page =~ m/Pergon.* ist .*offline/mo;
    $uptime =~ s/ und /, /g;
    my ($pages) = $page =~ m/GMPages = ([0-9]+)/mo;

    # find table lines and parse
    my %players = ();
    my @table = grep(m{<tr><td>.*</td></tr>}smo, split(m{\n}smo, $page));

    foreach (@table) {
        my ($name, $gender, $where) = m{
            # name
            <tr><td>(.*?)</td>
            # gender (first letter)
            <td>(.).*?</td>
            # position
            <td>(.*?)</td>
            # online time (ignored)
            <td>.*</td></tr>
        }smox;
        $players{$name} = {
            gender => $gender,
            where => $where,
        };
    };

    return (\%players, $time, $uptime, $pages);
} # }}}

sub get_configuration() { # {{{

    my $file;
    my @my_chars = (
        'Angeldor',
    );
    my @places = (
        'Gefaengnis',
    );
    my %observe = ();

    $file = $ENV{HOME} .'/work/pergon/.whowhere-mychars';
    if (-r $file) {
        open(ME, '<', $file) or
            die "Cannot read my chars from $file:\n$!";
        @my_chars = <ME>;
        chomp(@my_chars);
        close(ME);
    }

    $file = $ENV{HOME} .'/work/pergon/.whowhere-places';
    if (-r $file) {
        open(PLACES, '<', $file) or
            die "Cannot read interesting places from $file:\n$!";
        @places = <PLACES>;
        chomp(@places);
        close(PLACES);
    }

    $file = $ENV{HOME} .'/work/pergon/.whowhere-observe';
    if (-r $file) {
        open(OBSERVE, '<', $file) or
            die "Cannot read list of observed players from $file:\n$!";
        foreach (<OBSERVE>) {
            chomp;
            my ($type, $name) = m{^([\S ]+?)\s+--\s+(\S.*)$}smo;
            $observe{$name} = $type;
        }
        close(OBSERVE);
    }

    return(\@my_chars, \@places, \%observe);
} # }}}

# get options and configuration values, merge them {{{
my $only_names  = 0;
my $only_places = 0;
my $all_places  = 0;
GetOptions(
    'name|n'  => \$only_names,
    'place|p' => \$only_places,
    'all|a'   => \$all_places,
);
my $args = join(' ', @ARGV);
if ($all_places) {
    $only_names  = 0;
    $only_places = 0;
}
$only_names  = 0 if $only_places;
$only_places = 0 if $only_names;

my ($my_chars, $places, $observe) = get_configuration();
my ($players, $time, $uptime, $pages) = get_player_list();
unless (defined $players) {
    print "Pergon ist vermutlich offline\n";
    exit 0;
}

# merge players and observe
my @playkeys = keys %$players;
# maybe add command line arguments
$observe->{$args} = 'cmdline'
    if $args and not ($only_places or $all_places);
foreach my $obs (keys %$observe) {
    my @matching = grep(m{$obs}, @playkeys);
    if (@matching) {
        $players->{$_}{type} = $observe->{$obs} foreach (@matching);
    }
};
# }}}

# weed out the unwanted {{{
# find interesting places by location of own characters
push @$places,
    grep {
        $_ = $players->{$_}{where} if (defined $players->{$_})
    } @$my_chars;
# maybe add command line arguments
push @$places, $args if $args and not $only_names;

# find players of interest, put them in a hash (this will avoid duplicates)
my %interest = ();
foreach my $name (keys %$players) {
    $interest{$name} = 1
        if grep($players->{$name}{where} =~ m{$_}, @$places) or
            defined $players->{$name}{type} or $all_places;
}

# split by type
my @near    = grep { not defined $players->{$_}{type} } keys %interest;
my @friends = grep {     defined $players->{$_}{type} } keys %interest;
# }}}

# print out data {{{
print "$time (Uptime: $uptime; $pages Pages)\n";

# players near my chars and in special places
my $near = '';
foreach my $name (
    sort {
        lc($players->{$a}{where}) cmp lc($players->{$b}{where}) or
        lc($a) cmp lc($b)
    } @near
) {
    $near .= sprintf(
        "%  -30s %s (%s)\n",
        $players->{$name}{where}. ' --', $name, $players->{$name}{gender}
    );
}
print "Orte:\n$near\n" if $near;

# list online friends
my $friends = '';
foreach my $name (sort { lc($a) cmp lc($b) } @friends) {
    $friends .= sprintf(
        "%  -30s %s (%s) [%s]\n",
        $players->{$name}{where}. ' --', $name, $players->{$name}{gender},
        $players->{$name}{type}
    );
}
print "Freunde/Geschaeftspartner\n$friends" if $friends;
# }}}

exit;
