Here's the script:
#!/usr/bin/perl -w
use FindBin;
use lib "$FindBin::Bin/../lib";
use PerlMonks::StatsWhore;
use POSIX qw(strftime);
my $mbox_node = '15848';
my $DBFILE = "$FindBin::Bin/../var/monks.dat";
my $MSGFILE = "$FindBin::Bin/../var/monk-msg.dat";
my $LOGFILE = "$FindBin::Bin/../var/monks.log";
my $verbose = 0;
foreach (@ARGV) { $verbose++ if $_ eq '-v' };
my $sw = PerlMonks::StatsWhore->new(user => 'sfink',
password => 'p455wyrd')
or die "failed to create whore\n";
open(DB, $DBFILE) or die "open $DBFILE: $!";
my %info; # { nodeid => <current,creation date,[events]> }
while(<DB>) {
next if /^\s*\#/;
chomp;
my ($title) = /\s*\"(.*)\"$/;
s/\s*\".*\"$//;
my ($nodeid, $create_day, $create_time, $current, $lastcheck, @eve
+nts) =
split(/ /);
my $create = "$create_day $create_time";
$info{$nodeid} = [ $current, $create, $title, $lastcheck, \@events
+ ];
}
close DB;
open(LOG, ">>$LOGFILE") or die "append $LOGFILE: $!";
my $w = $sw->writeups_ref();
my $NOW = time();
foreach my $nodeid (keys %$w) {
my $info = $info{$nodeid};
my $d = $w->{$nodeid};
if ($info) {
my ($current, $create, undef, $lastcheck, $events) = @$info;
next if $current eq 'D'; # Deleted node
next if $current == $d->{rep};
my $curdate = strftime("%Y-%m-%d %H:%M:%S", localtime);
my $diff = $d->{rep} - $current;
$diff = "+$diff" if $diff > 0;
print "Update! $diff rep for \"$d->{title}\" created $create\n
+";
print LOG "$curdate M $nodeid $diff \"$d->{title}\"\n";
push @$events, "$lastcheck:".-$diff;
$info->[0] = $d->{rep};
} else {
# New node!
$info{$nodeid} = [ $d->{rep}, $d->{date}, $d->{title}, $NOW, [
+] ];
print LOG "$d->{date} C $nodeid \"$d->{title}\"\n";
print "New node! rep $d->{rep} \"$d->{title}\"\n";
}
}
# Find deleted nodes
my %had;
@had{keys %info} = ();
delete $had{$_} foreach (keys %$w);
foreach my $nodeid (keys %had) {
my $info = $info{$nodeid};
next if $info->[0] eq 'D';
print "Deleted! rep $info->[0] node \"$info->[2]\"\n";
print LOG "$NOW R $nodeid $info->[0] \"$info->[2]\"\n";
$info->[0] = 'D';
}
close LOG;
open(DB, ">$DBFILE") or die "write $DBFILE: $!";
print DB "# NODEID CREATED CURRENT-REP LASTCHECK EVENTS... TITLE\n";
my @nodes = sort { $info{$b}->[1] cmp $info{$a}->[1] } keys %info;
foreach my $nodeid (@nodes) {
my $info = $info{$nodeid};
my $line = "$nodeid $info->[1] $info->[0] $NOW ";
$line .= join(" ", @{ $info->[4] }); # Events
$line .= " " unless $line =~ / $/;
$line .= '"' . $info->[2] . '"';
$line .= "\n";
print DB $line;
}
close DB;
# Look for new messages
my %old_msgs;
if (-r $MSGFILE) {
open(MSG, $MSGFILE) or die "open $MSGFILE: $!";
while(<MSG>) {
chomp;
my ($id, $message) = split(/\s/, $_, 2);
$old_msgs{$id} = $message;
}
close MSG;
}
my %messages;
my $perlmonks = new PerlMonks::StatsWhore::XML(user => $sw->{user},
password => $sw->{passw
+ord});
$perlmonks->set_query(node => $mbox_node);
my $inbox = $perlmonks->fetch();
print $inbox if $verbose;
while ($inbox =~ m!\<message[^>]*message_id=.(\d+).[^>]*\>\s*(.*?)</me
+ssage>!sg) {
my ($id, $message) = ($1, $2);
next if defined($messages{$id} = delete $old_msgs{$id});
print " --- New message: $id ---\n\n$message\n\n";
$messages{$id} = $message;
}
while (my ($id, $message) = each %old_msgs) {
print " --- Deleted message: $id ---\n\n$message\n\n";
}
open(MSG, ">$MSGFILE") or die "create $MSGFILE: $!";
while (my ($id, $message) = each %messages) {
print MSG "$id $message\n";
}
close MSG;
The script uses a module I found here on PM called PerlMonks::StatsWhore. I think I may have made some minor changes. This is my version:
package PerlMonks::StatsWhore;
# Three Scripts for the Acolytes under the sky,
# seven for the Friar-lords in their halls of stone,
# nine for Mortal Bishops doomed to die,
# one for the Dark Saint on his dark throne
# in the Land of Monkwhore where the Black Stats lie.
# One Mod to rule them all,
# one Mod to find them,
# one Mod to bring them all
# and in the darkness bind them
# in the Land of Monkwhore where the Black Stats lie.
#
#
# Mucho original code by jcwren and larryl
# Objectified, merged, and tweaked by mojotoad
#
# Based on statswhore.pl, xstatswhore.pl, parts
# of luke_repwalker.pl and xluke_repwalker.pl
#
# See the POD for instructions.
#
# This code is public domain. Feel free to contact jcwren with tales
# of interesting applications.
use LWP::Simple;
use URI;
use Carp;
use POSIX qw(ceil floor);
use vars qw($VERSION);
$VERSION = '1.04';
my %Defaults = (
mode => 'XML',
binsize => 5,
);
sub new {
my $self = {%Defaults};
bless $self, shift;
my %parms = @_;
$self->{$_} = $parms{$_} for keys %parms;
$self->reset;
$self;
}
sub user {
my $self = shift;
if (@_) {
$self->{user} = shift;
$self->reset;
}
$self->{user};
}
sub password {
my $self = shift;
if (@_) {
$self->{password} = shift;
$self->reset;
}
$self->{password};
}
sub mode {
my $self = shift;
if (@_) {
$self->{mode} = shift;
$self->reset;
}
$self->{mode};
}
sub binsize {
my $self = shift;
if (@_) {
$self->reset_histogram;
$self->{binsize} = shift;
}
$self->{binsize};
}
sub reset {
my $self = shift;
delete $self->{cache};
$self->reset_summary;
$self->reset_histogram;
}
sub reset_summary { delete shift->{summary} }
sub reset_histogram { delete shift->{histogram} }
sub writeups_ref {
my $self = shift;
$self->fetch unless $self->{cache};
$self->{cache};
}
sub node_ids { sort { $a <=> $b } keys %{shift->writeups_ref} }
sub writeups {
my $self = shift;
@{$self->writeups_ref}{$self->node_ids};
}
sub writeup_count {
my $self = shift;
$self->fetch;
scalar keys %{$self->{cache}};
}
sub fetch {
my $self = shift;
return $self->{cache} if ref $self->{cache};
my $fetch_class = __PACKAGE__ . '::' . $self->mode;
eval "require $fetch_class";
my $fetcher = $fetch_class->new(user => $self->user, password => $se
+lf->password);
ref $fetcher or croak "Could not load class $fetch_class\n";
$self->{cache} = $fetcher->nodes(@_);
}
sub summary {
# code originally by jcwren
# Crammed into object by mojotoad
my $self = shift;
return $self->{summary} if ref $self->{summary};
my $total = 0;
my $repmax = 0;
my $repmin = 999999999;
$self->{summary}{repmax} = 0;
$self->{summary}{repmin} = 999999999;
foreach my $node ($self->writeups) {
$total += $node->{rep};
$self->{summary}{repmax} = max($self->{summary}{repmax}, $node->{r
+ep});
$self->{summary}{repmin} = min($self->{summary}{repmin}, $node->{r
+ep});
}
$self->{summary}{reputation} = $total;
$self->{summary}{average} = $total / $self->writeup_count;
$self->{summary};
}
sub repmax { shift->summary->{repmax} }
sub repmin { shift->summary->{repmin} }
sub reputation { shift->summary->{reputation} }
sub average { shift->summary->{average} }
sub summary_as_string {
# Code originally by jcwren
# Crammed into object method by mojotoad
my $self = shift;
my $total = 0;
$total += @$_[1] for (@$rarticles);
@$rarticles = sort {@$a[1] <=> @$b[1]} @$rarticles;
my $str;
$str .= sprintf (" User: %s\n", $self->user);
$str .= sprintf (" Total articles: %d\n", $self->writeup_count
+);
$str .= sprintf (" Total reputation: %d\n", $self->reputation);
$str .= sprintf (" Min reputation: %d\n", $self->repmin);
$str .= sprintf (" Max reputation: %d\n", $self->repmax);
$str .= sprintf ("Average reputation: %3.2f\n", $self->average);
$str .= "\n";
$str;
}
sub histogram_as_string {
# histogram code originally by larryl, modified by jcwren.
# Unceremoniously crammed into an object method by mojotoad.
my $self = shift;
# Divide articles into bins based on reputation:
my %bins = ();
my $binsize = $self->binsize;
$bins{floor (($_->{rep} + 0.5) / $binsize)}++ foreach ($self->writeu
+ps);
my @bins = sort {$a <=> $b} keys %bins;
my $minbin = $bins [0]; # lowest reputation bin
my $maxbin = $bins [-1]; # highest reputation bin
# Try to keep histogram on one page:
my $width = 50;
my $scale = 1;
my $maxrep = $self->repmax;
if ($maxrep > $width && $maxrep <= ($width * 5)) {
$scale = 5;
}
elsif ($maxrep > ($width*5)) {
while (($maxrep / $scale) > $width)
{
$scale *= 10;
}
}
my $start = $minbin * $binsize;
my $end = $start + $binsize - 1;
my $str;
$str .= " Reputation Article Count\n";
$str .= "------------- -------" . "-" x 50 . "\n";
do {
my $count = $bins {$minbin} || 0;
my $extra = ($count % $scale) ? '.' : '';
$str .= sprintf "%4d .. %4d \[%4d\] %s$extra\n", $start, $end, $c
+ount,
'#' x ceil ($
+count / $scale);
$start += $binsize;
$end += $binsize;
}
while ($minbin++ < $maxbin);
$str .= "\n Scale: #=$scale\n" if $scale > 1;
$str;
}
sub max {
my ($x, $y) = @_;
return ($x > $y ? $x : $y);
}
sub min {
my ($x, $y) = @_;
return ($x < $y ? $x : $y);
}
####################################
{
package PerlMonks::StatsWhore::Base;
# Main accessor: nodes()
#
# Subclass and override extract_writeups() and init_query()
use strict;
use Carp;
use LWP::Simple;
my %Defaults = ( url => 'http://www.perlmonks.org/index.pl' );
sub new {
my $class = shift;
my %parms = @_;
foreach (keys %Defaults) {
next if defined $parms{$_};
$parms{$_} = $Defaults{$_};
}
my $self = \%parms;
bless $self, $class;
$self->uri($self->make_uri($self->{url})) unless $self->uri;
$self->reset_writeups;
$self->init_query;
$self;
}
sub user {
my $self = shift;
@_ ? $self->{user} = shift : $self->{user};
}
sub password {
my $self = shift;
@_ ? $self->{password} = shift : $self->{password};
}
sub uri {
my $self = shift;
@_ ? $self->{uri} = shift : $self->{uri}
}
sub make_uri { shift; URI->new(@_) }
sub set_query {
my $self = shift;
my %parms = @_;
if (defined $self->user) {
$parms{user} = $self->user;
$parms{op} = 'login';
}
if (defined $self->password) {
$parms{passwd} = $self->password;
}
$parms{ticker} = "yes";
$self->uri->query_form(%parms)
}
sub fetch {
my $self = shift;
my $str = get($self->uri) or croak("Fetch failed for " . $self->ur
+i->as_string, "\n");
$str;
}
sub nodes {
my $self = shift;
$self->extract_writeups($self->fetch(@_)) unless scalar keys %{$se
+lf->{writeups}};
$self->{writeups};
}
sub add_writeups {
my($self, $wref) = @_;
foreach (keys %$wref) {
$self->{writeups}{$_} = $wref->{$_};
}
}
sub reset_writeups { shift->{writeups} = {} }
# Override
sub extract_writeups { shift->add_writeups(@_) }
sub init_query { croak "init_query() method must be overidden\
+n" }
}
{
package PerlMonks::StatsWhore::XML;
use strict;
use Carp;
require XML::Twig;
use base qw(PerlMonks::StatsWhore::Base);
sub init_query {
my $self = shift;
$self->set_query( node => 'User nodes info xml generator' );
}
sub extract_writeups {
my($self, $page) = @_;
$self->reset_writeups;
return unless $page;
my %nodehash = ();
my $twig = $self->make_xml_twig( TwigRoots => { NODE => $self->mak
+e_xml_twig_sub(\%nodehash) } );
$twig->parse($page);
# Remove home node from results
foreach (keys %nodehash) {
if ($nodehash{$_}{title} eq $self->{user}) {
delete $nodehash{$_};
last;
}
}
$self->add_writeups(\%nodehash);
}
sub make_xml_twig { shift; XML::Twig->new(@_) }
sub make_xml_twig_sub {
my($self, $nodehash) = @_;
ref $nodehash or croak "Hash ref required.\n";
sub { my ($t, $node) = @_;
my $nodeid = $node->att ('id');
!exists ($nodehash->{$nodeid}) or croak "Node $nodeid is dup
+licated!";
$nodehash->{$nodeid}{nodeid} = $nodeid;
$nodehash->{$nodeid}{title} = $node->text;
$nodehash->{$nodeid}{rep} = $node->att('reputation');
$nodehash->{$nodeid}{date} = $node->att('createtime');
$t->purge;
}
}
}
{
package PerlMonks::StatsWhore::HTML;
use strict;
use Carp;
require HTML::TableExtract;
use LWP::Simple;
use base qw(PerlMonks::StatsWhore::Base);
sub init_query {
my $self = shift;
$self->set_query(
node => 'Perl Monks User Search',
orderby => 'nf',
start => 0,
);
}
sub set_query {
my $self = shift;
my %params = @_;
$params{length} = $self->fetch_writeup_count;
$self->SUPER::set_query(%params);
}
sub fetch_writeup_count {
my $self = shift;
$self->user or croak "No username defined!\n";
my $c_uri = $self->uri->clone;
$c_uri->query_form(node => $self->user);
my $page = get(URI->new($c_uri)) or croak("Get failed for " . $c_u
+ri->as_string . "\n");
my $te = $self->make_table_extract(headers => ['User since', '\w+'
+]);
$te->parse($page);
my $w_count;
foreach my $row ($te->first_table_state_found->rows) {
if ($row->[0] =~ /Writeups/) {
$w_count = $row->[1];
last;
}
}
die "Failed to retrieve total writeup count." unless defined $w_co
+unt;
$w_count;
}
sub extract_writeups {
my $self = shift;
$self->reset_writeups;
return unless @_;
my $page = shift;
my $te = $self->make_table_extract(headers => ['Node ID', 'Writeup
+', 'Rep', 'Created']);
$te->parse($page);
my %nodehash;
foreach ($te->first_table_state_found->rows) {
$nodehash{$_->[0]}{nodeid} = $_->[0];
$nodehash{$_->[0]}{title} = $_->[1];
$nodehash{$_->[0]}{rep} = $_->[2];
$nodehash{$_->[0]}{date} = $_->[3];
}
$self->add_writeups(\%nodehash);
}
sub make_table_extract { shift; HTML::TableExtract->new(@_) }
}
1;
__END__
=head1 NAME
PerlMonks::StatsWhore - Perl module for tracking node stats on www.per
+lmonks.org
=head1 SYNOPSIS
use PerlMonks::StatsWhore;
# Default relies on XML ticker and XML::Twig
my $sw = PerlMonks::StatsWhore->new(
user => 'username',
password => 'password',
);
print $sw->summary_as_string;
print $sw->histogram_as_string;
# If you do not want to mess with XML::Twig, or are having
# trouble with odd characters in titles, fall back to
# HTML pages and HTML::TableExtract
my $sw2 = PerlMonks::StatsWhore->new(
user => 'username',
password => 'password',
mode => 'HTML',
);
print $sw->summary_as_string;
# Or pull statistics directly
print "User: ", $sw->user, "\n";
printf( "Average reputation: %5.2f\n", $sw->average );
printf( "Minimum reputation: %d\n", $sw->repmin );
printf( "Maximum reputation: %d\n", $sw->repmax );
printf( " Total reputation: %d\n", $sw->reputation );
=head1 DESCRIPTION
PerlMonks::StatsWhore fetches and calculates the reputation of your
nodes on www.perlmonks.org. The module encapsulates the functionality
and much of the code from the scripts C<statswhore.pl>,
C<xstatswhore.pl>, C<luke_repwalker.pl>, and C<xluke_repwalker.pl>
written by B<jcwren>, including the histogram code provided by
B<larryl>. The module has the advantage of allowing you to select eith
+er
XML or HTML fetch modes -- XML, the default, is faster. For those peop
+le
that have trouble installing XML::Twig(3) and its associated libraries
+,
choose HTML mode which uses traditional HTML page fetches and
HTML::TableExtract(3). If XML seems to be having problems with parsing
+ node titles due to "odd" characters, then use HTML and things should
+ work as intended.
If behind a proxy, set your C<html_proxy> environment variable to the
+URL of your proxy server, as per L<LWP::Simple>
=head1 METHODS
=over
=item new()
Return a new PerlMonks::StatsWhore object. Valid attributes are:
=over
=item user
PerlMonks account name.
=item password
Password for perlmonks account.
=item mode
Fetch mode. Valid choices are 'XML' and 'HTML' (case sensitive). XML
mode requires XML::Twig(3), XML::Parser(3), etc. HTML mode requires
HTML::TableExtract. XML mode is much faster and is the default mode.
=item binsize
Specifies the resolution of each bar of the histogram. Default 5.
=back
=item user()
=item password()
=item mode()
=item binsize()
Access or set the associated parameter.
=item summary_as_string()
String detailing username, article count, and reputation (total, min,
max, average)
=item histogram_as_string()
String depicting a histogram of article frequency vs. reputation.
=item repmax()
=item repmin()
=item reputation()
=item average()
Return relevant statistics for the current writeup list. Automatically
fetch writeups if not fetched already.
=item reset()
Resets summary statistics and writeup cache -- subsequent queries will
fetch a new list of writeups.
=item writeups()
Returns a list of writeup descriptors. Each is a reference to a hash
with the following keys: C<nodeid>, C<title>, C<rep>, C<date>
=item writeups_ref()
Returns a single reference to a hash of writeups, keyed by C<node_id>.
=item node_ids()
Returns a list of node_ids for all writeups -- suitable for use as key
+s
in the writeups_ref() hash.
=back
=head1 REQUIRES
LWP::Simple(3), XML::Twig(3) (only for XML mode), HTML::TableExtract(3
+) (only for HTML mode)
=head1 AUTHORS
Perlmonk B<jcwren> with contributions from B<larryl>. Crammed into a
module and modified by B<mojotoad>.
=head1 COPYRIGHT
Public domain. In the spirit of the original scripts, feel free to let
B<jcwren> know of any interesting applications inspired by the code.
=head1 SEE ALSO
LWP::Simple(3), URI(3), XML::Twig(3), HTML::TableExtract(3)
=cut
