use XML::Simple;
 
         my $config = XMLin();

##</code><code>##

<config>
  <perlmonks>
     <userid>your_pm_userid_here</userid>
     <password>your_passowrd_here</password>
  </perlmonks>
  <database>
     <driver>Pg</driver>
     <dbname>pmdata</dbname>
     <dbhost>your.database.host.here</dbhost>
     <dbuser>dbuser</dbuser>
     <dbpass>secret</dbpass>
  </database>
  <notification>
     <mailfrom>nobody@wherever.net</mailfrom>
     <pager>email@pagercompany.com</pager>
     <email>youself@yourisp.net</email>
  </notification>
</config>

##</code><code>##

CREATE TABLE messages (
    message_id integer NOT NULL,
    status character varying(20) NOT NULL,
    time_rcvd timestamp without time zone NOT NULL,
    author character varying(20) NOT NULL,
    content character varying(200) NOT NULL
);
 

##</code><code>##

#!/usr/bin/perl -w
########################################################################
#
#  $Id: PmChatPage.pl,v 1.4 2005/11/02 16:20:38 peter Exp $
#
#  $Log: PmChatPage.pl,v $
#  Revision 1.4  2005/11/02 16:20:38  peter
#  final touches to get it ready to be posted as a CUFP
#
#  Revision 1.3  2005/11/01 03:39:27  peter
#  DOH!  Forgot to load the notification addresses from the config file.
#
#  Revision 1.2  2005/11/01 03:33:57  peter
#  autodetect of host it is running on
#
#  Revision 1.1.1.1  2005/11/01 03:28:40  peter
#  This is the beginning of a beautiful thing.
#
#
#  Author: Peter L. Berghold
#
#  Purpose: Retrieve current messages from Perl Monks and send a copy
#           to my pager and email so I can stay on top of what is happening
#           at my favorite web site.
#           And it cannot be overlooked that this is for my own
#           amuzment and I amuze so easily.
#
########################################################################
$|=1;
 
use strict;
use DBI;
use XML::Simple;
use Data::Dumper;
use LWP::UserAgent;
use HTTP::Request::Common;
use HTTP::Cookies;
use MIME::Lite;
 
#
#       These variables will be configured by the PmChatPage.xml
#       contents via the XML::Simple parser.
# ----------------------------------------------------------------
 
my $conf_parser=new XML::Simple;
my $config= $conf_parser->XMLin();
 
 
my $DSN = sprintf("DBI:%s:database=%s;host=%s",
                  $config->{database}->{driver},
                  $config->{database}->{dbname},
                  $config->{database}->{dbhost});
 
 
 
 
 
my $dbh = DBI->connect($DSN,
                       $config->{database}->{dbuser},
                       $config->{database}->{dbpass},
                       {RaiseError=>1})
  or die DBI::errstr;
 
my $ua=LWP::UserAgent->new();
my $pm="http://www.perlmonks.org/index.pl";
 
$ua->cookie_jar({});   # set up a temporary cookie jar for my session
 
login($ua,$config);    # Log into Perl Monks
 
#
# Check my messages....
my @msg_list=get_messages($ua,get_max_id($dbh));
 
#
# If there are any, process them.
if ($#msg_list > -1 ) {
  process_messages($dbh,$config,@msg_list);
}
 
 
 
exit(0);
 
#
# This sub retrieves the highest id of the messages stored in the database
sub get_max_id {
  my $dbh = shift;
 
  my $sth = $dbh->prepare(qq@
                   select max(message_id) as message_id from messages
 @) or die $dbh->errstr;
  $sth->execute();
  my $row=$sth->fetchrow_hashref;
 
  return $row->{message_id};
 
}
 
 
#
# Logs into PerlMonks
sub login {
  my ($ua,$config)=@_;
  my $r=$ua->request( POST ($pm,[
                                 op=> 'login',
                                 user=> $config->{perlmonks}->{userid},
                                 passwd => $config->{perlmonks}->{password},
                                 expires => '+1y',
                                 node_id => '16046',
                                 ticker=>'yes'
                                ]));
 
}
 
#
# Slurp in the messages from the XML ticker.
sub get_messages {
  my ($ua,$msg_id)=@_;
  my $xs=new XML::Simple();
 
  my $response = $ua->request(GET("$pm?node_id=15848;since_id=$msg_id"));
  my $tree=$xs->XMLin($response->content);
 
  my @msgs=();
  if ($tree->{message}) {
 
    if ( ref($tree->{message}) eq 'ARRAY' ) {
      push @msgs,@{$tree->{message}};
    } else {
      push @msgs,$tree->{message};
    }
 
  }
 
  return @msgs;
}
 
#
# Store the messages into the database and send the notifications out.
sub process_messages {
  my $dbh=shift;
  my $config=shift;
  my $sth=$dbh->prepare(qq(
insert into messages(message_id,status,time_rcvd,author,content)
    values (?,?,?,?,?)
)
 
) or die $dbh->errstr;
 
 
  foreach my $msg (@_) {
    my $raw_time = $msg->{time};
    my $msg_id = $msg->{message_id};
    my $content = $msg->{content};
    my $status = $msg->{status};
    my $author = $msg->{author};
 
    $content =~ s/\n+//g;
 
    $raw_time =~ m@^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$@;
 
 
 
    my ($year,$month,$day,$hour,$minute,$seconds)=($1,$2,$3,$4,$5,$6);
 
    my $timestamp=sprintf("%0.4d-%0.2d-%0.2d %0.2d:%0.2d:%0.2d",
                          $year,$month,$day,$hour,$minute,$seconds
                         );
    $sth->execute($msg_id,$status,$timestamp,$author,$content)
      or die $sth->errstr;
 
    my $mail_text = sprintf("Message from %s\n%s",$author,$content);
    my $mail_msg = MIME::Lite->new(
                                   From => $config->{notification}->{mailfrom},
                                   To => $config->{notification}->{pager},
                                   Cc => $config->{notification}->{email},
                                   Subject => 'Messages on PerlMonks',
                                   Type=> 'TEXT',
                                   Data=> $mail_text
                                  );
     
    $mail_msg->send;
     
  }
}