#!/usr/bin/perl -w
use strict;
$|=1;
use Dumpvalue;
my $d= new Dumpvalue;

#
#  this is an experimental script that parses the various results from the
#  breedster webserver all results are cached locally in a subdirectory
#  'cache' login is only attempted when data from the server is needed if you
#  want the get fresh data from the server you have to manually delete the
#  files from the cache.
#
#  idea is that this script could serve as a basis for a breedster bot.
#
#


#############################################################################
# this is a simple interface to a webserver.
package WebServer;
use HTTP::Request::Common qw(POST GET);
use LWP::UserAgent;
use HTTP::Cookies;

use List::Util qw(first);

sub new {
    my ($class, $baseurl)= @_;

    my $ua= LWP::UserAgent->new(agent=>'Fornicator/1.0');
    $ua->cookie_jar(HTTP::Cookies->new());
    $ua->env_proxy();

    return bless {
        ua=>$ua,
        baseurl=>$baseurl,
    }, $class;
}
# almost interface compatible with httpost
#   - optional hashref with parameters is merged with parameters.
#
# httpget("/some.cgi", key1=>123, key2=>455);
# httpget("/some.cgi", { urlkey1=>999 }, key1=>123, key2=>455);
#
sub httpget {
    my $self= shift;
    my $path= shift;

    my $query;
    if (@_) {
        $query= shift;
        if (ref $query ne "HASH") {
            unshift @_, $query;
            $query=undef;
        }
    }
    my %params= @_;

    my $uri= URI->new($self->{baseurl});
    $uri->path($path);
    $uri->query_form($query?%$query:(), %params);
    my $rq= GET $uri;

    my $rp= $self->{ua}->request($rq) or die "httperror: $@\n";

    return $rp->content;
}

# can be called in several ways:
# httppost("/some.cgi", key1=>123, key2=>455);
#   -> just form values
# httppost("/some.cgi", { urlkey1=>999 }, key1=>123, key2=>455);
#   -> both url and form params
# httppost("/some.cgi", key1=>123, key2=>455, file1=>["filename"]);
#   -> form-data file upload
sub httppost {
    my $self= shift;
    my $path= shift;

    my $query;
    if (@_) {
        $query= shift;
        if (ref $query ne "HASH") {
            unshift @_, $query;
            $query=undef;
        }
    }
    my %params= @_;

    my $uri= URI->new($self->{baseurl});
    $uri->path($path);
    $uri->query_form(%$query) if ($query);
    my $rq= POST $uri, [ %params ];

    # -- for http uploads : 
    # ( Content_Type=>"form-data", Content=>[ %params ]);

    my $rp= $self->{ua}->request($rq) or die "httperror: $@\n";

    #print $rp->status_line, "\n";
    #print $rp->headers->as_string();

    return $rp->content;
}

sub httprequest {
    my ($self, $method, @params)= @_;
    if (lc($method) eq "get") {
        return $self->httpget(@params);
    }
    elsif (lc($method) eq "post") {
        return $self->httppost(@params);
    }
    else {
        die "invalid http request method '$method'\n";
    }
}

# http testing
sub tst {
    my $self= WebServer->new("http://itsme.dyndns.org");

    # test just url.
    print $self->httprequest("GET", "/cgi-bin/tst.cgi");
    # test just url.
    print $self->httprequest("POST", "/cgi-bin/tst.cgi");

    # test weird value encoding
    print $self->httprequest("GET", "/cgi-bin/tst.cgi", a=>"&=?", "&=?"=>"\000");
    # test multi values
    print $self->httprequest("GET", "/cgi-bin/.cgi", tst1=>[1,2,3], a=>"1", "b"=>"1");

    # test interchangablilty with post
    print $self->httprequest("GET", "/cgi-bin/tst.cgi", {qq=>11, zz=>22}, a=>1, b=>2, c=>3);

    # test post form value
    print $self->httprequest("POST", "/cgi-bin/tst.cgi", a=>1, b=>2, c=>3);
    # test post form value with urlparams
    print $self->httprequest("POST", "/cgi-bin/tst.cgi", {qq=>11, zz=>22}, a=>1, b=>2, c=>3);

    # test file upload
    print $self->httprequest("POST", "/cgi-bin/tst.cgi", {qq=>11, zz=>22}, a=>"sometext", b=>["/etc/motd"]);
}


package Breedster;

use IO::File;

sub new {
    my $class= shift;
    my $user= shift;
    my $pass= shift;


    my $self= bless {
        server=> WebServer->new("http://breedster.drunkmenworkhere.org"),
        user=>$user,
        pass=>$pass,
    }, $class;

    $self->readprofile();
    return $self;
}

sub post {
    my ($self, @params)= @_;
    $self->{server}->httppost(@params);
}
sub get {
    my ($self, @params)= @_;
    if (!$self->{loggedin}) {
        $self->login();
    }
    $self->{server}->httpget(@params);
}
sub readfile {
    my $fn= shift;
    my $fh= IO::File->new($fn, "r") or die "$fn: $!\n";
    binmode $fh;
    my $data;
    $fh->read($data, -s $fh);
    $fh->close();

    return $data;
}
sub savefile {
    my $fn= shift;
    my $data= shift;
    my $fh= IO::File->new($fn, "w+") or die "$fn: $!\n";
    binmode $fh;
    $fh->write($data);
    $fh->close();
}
sub filename_escape {
    my $fn= shift;

    $fn =~ s/-/--/g;
    $fn =~ s/[^a-z0-9.A-Z]/sprintf("-%02x", ord($&))/ge;

    return $fn;
}
sub encodeurlasfile {
    my ($path, %params)= @_;

    return "cache/".join("_", filename_escape($path), map { (filename_escape($_) => filename_escape($params{$_})) } sort { lc($a) cmp lc($b) } keys %params);
}
sub cachedget {
    my ($self, @params)= @_;

    my $filename= encodeurlasfile(@params);

    if (-e $filename) {
        return readfile($filename);
    }

    my $data= $self->get(@params);

    savefile($filename, $data);

    return $data;
}


sub DESTROY {
    my $self= shift;
    if ($self->{loggedin}) {
        $self->logout();
    }
}
sub login {
    my ($self)= @_;

    my $result= $self->post("/index.php", 
        #'redir'=>'profile.php', 
        'breedster[username]'=>$self->{user},
        'breedster[password]'=>$self->{pass});

    if ($result =~ /Too many users connected/) {
        die "Too many users connected";
        return;
    }
    if ($result ne "") {
        die "unknown answer from server: $result";
        return;
    }

    $self->{loggedin}= 1;
}

sub getbig_profile_property {
    my $str= shift;
    my $key= shift;

    if ($str =~ /<p><b>$key<\/b><br \/>\s+(.*?)<\/p>/s) {
        return $1;
    }
    return "";
}
sub readprofile {
    my $self= shift;
    my $id= shift;

    my $result= $self->cachedget("/profile.php", $id?(id=>$id):());

    my $profile = {
        fullname=> ($result =~ /<div class="t">(.*?)\s*<div/),
        id=> ($result =~ /<img src="members\/(\d+)\.png"/),
        gender=> ($result =~ /gender:\s+(\w+)/),
        status=> ($result =~ /status:\s+(\w+)/),
        age=> ($result =~ /age:\s+(.*)/),
        energy=> ($result =~ /energy:\s+(\d+)/),
        parents=> ($result =~ /parents:\s+(\d+)/),
        partners=> ($result =~ /partners:\s+(\d+)/),
        children=> ($result =~ /children:\s+(\d+)/),
        food=> ($result =~ /food:\s+<span style="background:#(\w+);?">/),
        excrement=> ($result =~ /excrement:\s+<span style="background:#(\w+);?">/),

        tagline=>         getbig_profile_property($result, "tagline"),
        occupation=>      getbig_profile_property($result, "occupation"),
        location=>        getbig_profile_property($result, "location"),
        website=>         getbig_profile_property($result, "website"),
        about_me=>        getbig_profile_property($result, "about me"),
        interests=>       getbig_profile_property($result, "interests"),
        favourite_stuff=> getbig_profile_property($result, "favourite stuff"),
        wants_to_meet=>   getbig_profile_property($result, "wants to meet"),
    };
    if ($profile->{website} =~ /<a href="http:\/\/(.*?)"/) {
        $profile->{website} =  $1;
    }

    # todo: intestines

    # todo: testimonials

    
    if (!$id) {
        $self->{profile}= $profile;
    }
    $self->{profiles}{$profile->{id}}= $profile;
}
sub getprofile {
    my $self= shift;
    my $id= shift;
    if ($id) {
        if (!exists $self->{profiles}{$id}) {
            $self->readprofile($id);
        }
        return $self->{profiles}{$id};
    }
    return $self->{profile};
}
sub readcopulogram {
    my $self= shift;
    my $id= shift;

    my $profile= $self->getprofile($id);

    my %copulogram; 

    $profile->{copulogram}= \%copulogram;

    my $result= $self->cachedget("/copulogram.php", id=>$profile->{id});

    my $curchildlist;
    my $reading= "";
    for (split /[\r\n]+/, $result) {
        if ($reading eq "" && /<div class="parents">/) {
            $reading="parents";
        }
        elsif ($reading eq "parents" && /class="icon"/) {
            my (@pnts)= /<a href="\/copulogram.php\?id=(\d+)"/g;
            $copulogram{parents}= \@pnts;
            $reading= "";

            $self->readprofile($_) for (@pnts);
            $self->readcopulogram($_) for (@pnts);
            $self->trackposition($_) for (@pnts);
        }
        elsif ($reading eq "" && /<div class="(?:last)?partner">/) {
            my $partnerid;
            if (/<a href="\/copulogram.php\?id=(\d+)"/) {
                $partnerid= $1;
            }
            elsif (/deceased/) {
                $partnerid= -1;
            }
            else {
                warn "??? no partner strign in $_\n";
                $partnerid= 0;
            }
            $curchildlist= [];
            push @{$copulogram{partners}}, {
                id=>$partnerid,
                children=>$curchildlist,
            };
        }
        elsif ($reading eq "" && /<div class="children">/) {
            $reading= "children";
        }
        elsif ($reading eq "children" && /<div class="(last)?child">/) {
            if ($1) {
                $reading= "";
            }
            my $childid;
            if (/deceased\.png/) {
                $childid= -1;
            }
            elsif (/egg\.png/) {
                $childid= 0;
            }
            elsif (/\/copulogram\.php\?id=(\d+)/) {
                $childid= $1;
            }
            push @$curchildlist, $childid;
        }
    }
}
sub trackposition {
    my $self= shift;
    my $id= shift;

    if (!defined $id || !$id || $id==$self->{profile}{id}) {
        $self->findposition();
        return;
    }

    my $result= $self->cachedget("/grid.php", track=>$id, name=>"trackname");

    if ($result =~ /trackname<\/a> is located (\d+) steps? (\w+)(?: and (\d+) steps? (\w+))/) {
        $self->{profiles}{$id}{position}= [$self->resolverelative($2=>$1, $4?($4=>$3):())];
    }
}
sub resolverelative {
    my $self= shift;
    my %pos= @_;

    my $dx= exists $pos{left}?-$pos{left} : exists $pos{right} ? $pos{right} : 0;
    my $dy= exists $pos{up}?-$pos{up} : exists $pos{down} ? $pos{down} : 0;

    if (!exists $self->{profile}{position}) {
        $self->findposition();
    }

    return ($self->{profile}{position}[0]+$dx, $self->{profile}{position}[1]+$dy);
}
sub findposition {
    my $self= shift;

    my $result= $self->cachedget("/zoom.php");
    my ($top, $left)= ($result =~ /"self".*?top:(\d+)px;left:(\d+)px;/);
    my ($gridwidth, $gridheight)= ($result =~ /"grid.png".*?width(\d+)px;height(\d+)px;/);

    $self->{profile}{position}= [$left+31, $top+31];
}
sub logout {
    my $self= shift;

    my $result= $self->get("/logout.php");

    if ($result !~ /login/ || $result !~ /forgot password/) {
        warn "unknown logout page: $result\n";
    }

    $self->{loggedin}= 0;
}

sub getallusers {
    my $self= shift;

    my $result= $self->cachedget("/search.php", action=>'search', str=>'%', part=>'true');

    for ($result =~ /<li>(<a.*?)<\/li>/g) {
        if (/^<a href="profile.php\?id=(\d+)">(.*?)\s*<\/a>(?:: (.*?))?<br \/>(?:<a href=".*?".*?>(.*?)<\/a>)?$/) {
            my ($id, $fullname, $tagline, $website)= ($1, $2, $3, $4);

            $tagline ||= "";
            $website ||= "";
            if  (exists $self->{profiles}{$id}) {
                my $p= $self->{profiles}{$id};
                if ($p->{fullname} ne $fullname) { warn "$id: ($p->{fullname} ne $fullname)\n"; }
                if ($p->{tagline} ne $tagline) { warn "$id: ($p->{tagline} ne $tagline)\n"; }
                if ($p->{website} ne $website) { warn "$id: ($p->{website} ne $website)\n"; }
            }
            else {
                my $p= $self->{profiles}{$id}= {
                    fullname=>$fullname,
                    tagline=>$tagline,
                    website=>$website,
                    id=>$id,
                };
            }
        }
        else {
            warn "could not parse list entry $_\n";
        }
    }
}

package main;

my $wj= Breedster->new("user", "pass");
$wj->readcopulogram();
$wj->getallusers();

#$d->dumpValue($wj);

print "------------------------\n";