Re: Changes to the User Nodes ticker and introducing the NodeRep XML ticker (simple client)

Here is a simple client that maintains a Node DB from the user nodes ticker and updates it from the Noderep ticker. It populates the node db _first_ so if you have made a lot of posts, it could take a while before it picks them all up and starts polling the noderep ticker.

use XML::Simple;
use HTTP::Request::Common qw(POST);
use LWP::UserAgent;
use HTTP::Cookies;
use Storable;
use DB_File;
use MLDBM qw(DB_File Storable);
use strict;
use warnings;

my $CLEAR_ON_FIRST_FETCH = 0; # enable for debugging

sub get_pm_xml {
    my $ua      = shift;
    my $node_id = shift;

    my $req = POST 'http://www.perlmonks.org',
                [
                  node_id => $node_id,
                  @_,
                  xmlstyle   => 'stream,flat',
                ];

    my $resp=XMLin($ua->request($req)->content);

    # cleanup older tickers that dont return
    # result sets consistant with the newer ones.
    my @keys=keys %$resp;
    foreach my $key (@keys) {
        if (lc($key) ne $key and !$resp->{lc($key)}) {
            $resp->{lc($key)}=delete $resp->{$key};
        }
    }

    return $resp;
}

sub login {
    my ($user,$pass,$cookie_jar)=@_;

    die "Must have User and Pass arguments"
        if !$user or !$pass;

    $cookie_jar||="$0.cookie";

    my $ua = LWP::UserAgent->new;
    $ua->cookie_jar(
        HTTP::Cookies->new(
             file => "$0.cookie",
             autosave => 1
        )
    );

    my $resp = get_pm_xml($ua,109,
        op         => 'login',
        user       => $user,
        passwd     => $pass,
        expires    => '+10y',
        sexisgood  => 'submit',
        ticker     => 'yes',
        displaytype => 'xml',
    );

    return $resp && $resp->{loggedin} ? $ua : undef;
}

sub fetch_nodes {
    my ($ua,$db,$file)=@_;

    $file ||= "$0.dbf";
    if (!$db) {
        my %db;
        tie %db, 'MLDBM', $file, O_CREAT|O_RDWR, 0640 or die $!;
        # Ask for portable binary
        (tied %db)->DumpMeth('portable');
        $db=\%db;
    }

    my $lastid=$db->{lastid};
    $lastid||=0;
    my $count=0;
    my $sleep=0;
    do {
        if ($sleep) {
            print "(sleeping for $sleep seconds)\n";
            sleep $sleep;
        }
        print "Fetching records since '$lastid'\n";
        my $resp=get_pm_xml($ua,32704,
            fromid => $lastid,
        );
        $resp->{node} ||= {}; # simulate an empty list.
        $resp->{node} = { $resp->{node}{node_id} => $resp->{node} }
            if ref $resp->{node} ne "HASH";
        $sleep = $resp->{info}{min_poll_seconds};
        foreach my $id (keys %{ $resp->{node} }) {
            $db->{$id} = $resp->{node}{$id};
            $lastid=$id if $lastid<$id;
        }
        $count=keys %{$resp->{node}};
        $db->{lastid}= $lastid;
        (tied %$db)->UseDB()->sync(); # flush our data so far.
        print "Got $count records\n";
    } until $count<100;
    $db->{lastid}=$lastid;
    return $db;
}

sub poll_rep {
    my ($ua,$db)=@_;
    my $sleep=0;
    do {
        if ($sleep) {
            print "(sleeping for $sleep seconds)\n";
            sleep $sleep;
        }
        print "Checking for noderep changes\n";
        my $resp=get_pm_xml($ua , 507310,
          $CLEAR_ON_FIRST_FETCH && !$sleep
           ? (clear=>1)
           : ()
        );
        $sleep=$resp->{info}{min_poll_seconds};
        $resp->{node}||=[]; # simulate an empty list.
        $resp->{node}=[$resp->{node}] if ref $resp->{node} ne "ARRAY";
        my $count=@{ $resp->{node} };
        print "Got $count records\n";
        foreach my $msg ( @{ $resp->{node} } ) {
            if (!exists $db->{$msg->{node_id}}) {
                print "Looks like you made a new post. Updating DB.\n"
+;
                fetch_nodes($ua,$db);
                last; #
            }
        }
        foreach my $msg ( @{ $resp->{node} } ) {
            printf "%3d #%-8s %s\n",
               $msg->{delta},
               $msg->{node_id},
               $msg->{content};
            my $dbrec=$db->{$msg->{node_id}};
            $dbrec->{$_}=$msg->{$_}
                for qw(content reputation node_id);
            $db->{$msg->{node_id}}=$dbrec;
        }
        (tied %$db)->UseDB()->sync(); # flush our data so far.
    } while 1;
}

$|++;

my ($user,$pass,$reset)=@ARGV;

if ($reset) {
    unlink "$0.cookie","$0.dbf","$0.db";
}
my $ua= login( $user, $pass ) or die "Failed login\n";
my $db= fetch_nodes($ua) or die "Weird!";
poll_rep($ua,$db);
[download]

Note the client is compliant in that it determines its polling period automatically based on the information in the 'info' tag from the previous fetch.

Apologies to davido and bobf to not using their code for this, I wanted to see how long it would take to write from scratch (not too long :-)

Update: I modified the code slightly as it blew up when only one node was returned by either ticker.

---
$world=~s/war/peace/g

Comment on Re: Changes to the User Nodes ticker and introducing the NodeRep XML ticker (simple client) Download Code


The stupid question is the question not asked
	PerlMonks