#!/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 =~ /
$key<\/b>
\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 =~ /
(?:(.*?)<\/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";