comment on

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

In reply to Re: Changes to the User Nodes ticker and introducing the NodeRep XML ticker (simple client) by demerphq
in thread Changes to the User Nodes ticker and introducing the NodeRep XML ticker by demerphq

Are you posting in the right place? Check out Where do I post X? to know for sure.
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
Want more info? How to link or How to display code and escape characters are good places to start.


Do you know where your variables are?
	PerlMonks