Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

The whore-by-mail game

by sfink (Deacon)
on Nov 05, 2005 at 07:34 UTC ( #505951=sourcecode: print w/ replies, xml ) Need Help??

Category: PerlMonks.org Related Scripts
Author/Contact Info sfink
Description: This is (part of) my crontab file:
MAILTO=steve@fink.com # r----minute # | r-----hour # | | r------day of the month # | | | r------month # | | | | r------day of the week # | | | | | r------ command to run ----------> # | | | | | | 0 10 * * * /home/sfink/bin/whore 0 18 * * * /home/sfink/bin/whore
This will email me an update saying which of my nodes have gained or lost reputation in the last day, and whether I have any new private msgs. It's rough, it uses flat files, and it assumes a particular directory structure (I have bin/, lib/, and var/ subdirectories under my home dir). Oh, and I use a text-only mail reader that doesn't open up links I click on, so the output is text-only. (It would be trivially easy to make the new message notifications be links.)

It will also keep a complete historical log of all the changes.

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

I work for Reactrix Systems, and am willing to admit it.

Comment on The whore-by-mail game
Select or Download Code
Re: The whore-by-mail game
by spiritway (Vicar) on Feb 12, 2006 at 08:20 UTC

    Whore today, gon tomorrow...

      Whore today, gon tomorrow...
      I hope you don't mean me ;-)

      --------------------------------------------------------------

      "If there is such a phenomenon as absolute evil, it consists in treating another human being as a thing."
      John Brunner, "The Shockwave Rider".

      Can you spare 2 minutes to help with my research? If so, please click here

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://505951]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (12)
As of 2015-07-07 00:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (85 votes), past polls