Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
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 lurking in the Monastery: (10)
As of 2014-08-21 20:58 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (143 votes), past polls