#!/usr/bin/perl -w
=head1 DESCRIPTION - what is this cbLast'ed thing?
Well it keeps a DB_File of the last 35 messages
uttered in the cb, so if you walk in on something I<interesting>,
you can catch up without saying: "what are you guys talking about?"
=head1 USAGE
make a crontab entry looking like
*/5 * * * * cd /path/to/script/ && ./cblast35.pl>/dev/null
*/5 * * * * cd /home/crazyinsomniac/public_html/perl/cblast35/ && ./c
+blast35_pl.txt>/dev/null
You can do it using crontab -e.
You really shouldn't run it more than every 6 minutes, but because
of how cron works and whatnot, 5 will do.
Don't run it more often than 4 minutes, cause the whole point
is to get the last 35 messages so if you walk in something you know
what is up, not use it as a replacement to framechat ;)
This is not a cb client
=cut
BEGIN # better then getting mail fron cron when the script fails
{ # even if it is a "performance penalty", but really, its not ;-)
use CGI::Carp qw(carpout);
open(LOG, ">>cblast35.err.log") or
die "can't append to cblast35.pl.err.log: $!";
carpout(\*LOG);
}
use strict; # Fo' health and pleasure
use XML::Parser; # Fo' parsering'em XML
use DB_File; # Fo' da db
use Fcntl; # Fo' da constants
use IO::File; # OOP is the life for me
use LWP::UserAgent; # Fo' fetching'em tickers
require HTTP::Request;
require HTTP::Response;
# why must you be constantly annoying ?!?!
use constant PM => 'http://www.perlmonks.org/index.pl';
# globals
use vars qw($dbfile $semaphore);
$dbfile = 'cb.ticker.db'; # this you can change to preference
$semaphore = 'semaphore.'.$dbfile.'.lock';
# it begins
{
my $cbtickerurl = PM.'?node_id=15834';
my $dangtimeout = 15;
# apparently, this is not the timeout for the entire session
# but for each packet ([id://79502])
my $messages = &fetch_cb_xml($cbtickerurl,$dangtimeout);
die "message hash is empty, impossible!!" unless defined %{$messag
+es};
&tyebinds($messages);
undef $messages;
}# it ends
exit;
######################################################################
+########
###### - \ | / ~ \ | / - \ | / ~ \ | / - \ | / ~ \ | / - \ | / ~ S U B
+ L A N D
=head2 C<&can_i_write>
simple semaphore file test, no file locking, cause I run winblows
If the file exists, and it's not older than five minutes,
wait five seconds and check again how old it is (once).
unlink if older than 5 minutes, and create a new one
=cut
sub can_i_write
{
my $counter = 0;
if(-e $semaphore)
{
CHECKTIME:
$counter++;
my $modified = time - (stat $semaphore)[9];
if($modified > 300) # 60 * 5 # it's older than 5 minutes
{
print "Trying to unlink expired $semaphore...";
print((unlink $semaphore)?" success!\n":" failure!\n");
return 1 if &_semaphore($semaphore,1);
}
else
{
sleep 5;
goto CHECKTIME unless $counter == 3; # we try twice
# if you modify this, think of the server timeout
# and think of the crontab
}
return 0;
}
return 1;
}
=head2 C<&_semaphore($semaphore,1)>
C<$semaphore> is the name of the file.
The second arg signifies the status of $semaphore to be achieved
C<(O_CREAT || unlink);>
If asked for to create a semaphore file, and it does,
returns 1, otherwise returns 0
=cut
sub _semaphore
{
my $fh = shift;
my $td = shift;
if($td)
{
$fh = new IO::File $fh,
O_CREAT| # Create the file if it doesn't exist
O_EXCL; # Fail if the file already exists
if(defined $fh)
{
undef $fh; # automatically closes the file
return 1;
}
else
{ return 0; }
}
else
{
print "deleting $fh", unlink $fh,"\n";
}
}
=head2 C<&tyebinds($messages);>
Takes a reference to the freshly fetched messages.
asks L<&can_i_write> for I<permission>.
If denied, sleeps five seconds, and asks again.
die's if it doesn't get permission.
If it does get permission (a semaphore file is created),
it updates the DB_File database with the new messages,
and then removes all but the last 35 messages,
untie's the hash, and deletes the semaphore file
=cut
sub tyebinds
{
my $newmessages = shift;
unless(&can_i_write)
{
sleep 5;
die "$dbfile is in use at the moment"
unless &can_i_write
}
# if you ain't dead by
tie my %DBHASH, 'DB_File', $dbfile,
O_RDWR|O_CREAT, 0644, new DB_File::BTREEINFO;
# update the message hash
for my $timestamp(sort keys %{$newmessages})
{
my $idn = $newmessages->{$timestamp}->{monkid};
my $nym = $newmessages->{$timestamp}->{monk};
my $msg = $newmessages->{$timestamp}->{message};
$DBHASH{$timestamp} = sprintf '%s|%s|%s', $idn, $nym,$msg;
}
undef $newmessages;
# delete the messages which are not the last 35
my $msgcount = 0;
for my $key(reverse sort keys %DBHASH)
{
delete $DBHASH{$key} if ++$msgcount > 35;
}
untie %DBHASH;
&_semaphore($semaphore,0); # remove the semaphore
}
=head2 C<fetch_cb_xml($cbtickerurl)>
uses LWP::UserAgent to fetch the xml from $cbtickerurl.
Dies if this fails.
If it does not, uses XML::Parser to build a hash of the current messag
+es,
which is never more than 20(IIRC, or the last 8 minutes if things are
+slow),
and returns a reference to that hash (C<\%messages>).
=cut
sub fetch_cb_xml
{
my ($cbtickerurl,$dangtimeout) = @_;
die("&fetch_cb_xml takes two params")unless($cbtickerurl && $dangt
+imeout);
# why redundancy, dudn't hurt much
my $raw_xml = &requestitraw($cbtickerurl,$dangtimeout);
die "LWP::Simple::get ate it on $cbtickerurl ($!)"
unless(length $raw_xml > 4);
# self documenting code is goood, but comments can't hurt
my $messages = {};
my $xml_parser = new XML::Parser(
Handlers => {
Start => \&_xml_start,
End => \&_xml_end,
Char => \&_xml_char,
Default => \&_xml_def,
}
);
$xml_parser->{crazy_hashref_b392} = $messages;
# make sure you don't call "crazy_hashref_b392"
# "Handler" or some other key the module uses ;-)
$xml_parser->parse($raw_xml); # parse the xml, &fill {crazy_hashre
+f_b392}
undef($raw_xml); # kinda redundant, but i like redund
+ancy
undef($xml_parser); # paranoia
return $messages;
}
=head2 C<&requestitraw($cbtickerurl,$dangtimeout);>
Uses HTTP::Request along with LWP::UserAgent to fetch
the latest messages.
=cut
sub requestitraw
{
# LWP simple would've been fine, but hey, I wanted to use UserAgent
# But, Dangit Jim, I wanted a timeout
my ($toget, $dangtimeout) = @_;
my $REQUS = new HTTP::Request(GET => $toget);
my $USERA = new LWP::UserAgent();
$USERA->agent("cb Last 35 - crazy is good 4.98");
$USERA->timeout($dangtimeout||30 ); # in case you think you're
+smart
my $RESPO = $USERA->simple_request($REQUS);
die "the $toget request failed" if(!$RESPO->is_success && $RESPO->
+is_error);
return $RESPO->content;
}
########### YOU CAN'T HAVE ANY PUDDIN', UNTIL YOU EAT YOUR MEAT ######
+##########
######################################################################
+##########
## Thank you id://62782 ####,
# The XML::Parser Handlers
sub _xml_start # beginning tag
{
my ($expat, # the object who invoked the sub
$name, # what to do
%attributes) = @_; # wood for the chipper(what the fu'?
my $msghash = $expat->{crazy_hashref_b392};# don't call it Handler
+s ;-)
# 20010723134509
#<message author="virtualsue" user_id="70099" time="20010723134509">:)
+</message>
if($name eq 'message')
{
my $userid = $attributes{'user_id'};
my $author = $attributes{'author'};
my $timest = $attributes{'time'};
$expat->{mark} = # the trigger
$msghash->{$timest} = {monkid => $userid,
monk => $author,
message => ''};
}
}
sub _xml_char # more like text (tag encapsulated stuff)
{
my ($expat, $not_markup) = @_;
if(exists $expat->{mark} and defined $expat->{mark})
{
# this be the stuff in between message tag
+s
$expat->{mark}->{message} .= $not_markup;
# i .= append because XML::Parser chuncks
}
}
sub _xml_def{}
# mostly space, with some tabs and newlines sprinkled about the north
+west area
sub _xml_end # it's an *end* (closing) tag
{
my ($expat, $name) = @_;
undef($expat->{mark}); # after the tag close, we wait for the nex
+t one
}
__END__
## this be called cblast35.cgi
######################################################################
+######
#!/usr/bin/perl -w
use strict;
use CGI qw¡:standard *table *Tr *td¡;
$CGI::DISABLE_UPLOADS = 1;# Disable uploads
$CGI::POST_MAX =-1;# Maximum number of bytes per post
use CGI::Carp q!fatalsToBrowser!;
use DB_File;
use Fcntl;
# D'loop Mayno
{
$|=1;
# ChatterboxXMLTicker
my $pmurl = 'http://perlmonks.org/index.pl?';
print header(-type => 'text/html',
-expires => '+5m' ), # cache only for five minutes
start_html('-title' => "cb Last 35",
'-dtd' => "-//W3C//DTD HTML 4.0 Transitional//
+EN"),
basefont({face => "Arial",
size => "2",
color => "black"}),
h3("gmtime is ", &_timestamp), start_form,
start_table({cellspacing => 2, width => "100%",
cellpadding => 2, border => 1});
my $dbfile = 'cb.ticker.db'; # this you can change to preferenc
+e
tie my %messages, 'DB_File', $dbfile, O_RDONLY,
0644, new DB_File::BTREEINFO;
for my $ttime (sort keys %messages)
{
my $msg = $messages{$ttime};
substr($ttime,12,0,':'); # get it in perlmonks format
substr($ttime,10,0,':'); # yyyy-mm-dd hh:mm:ss
substr($ttime,8,0,' ');
substr($ttime,6,0,'-');
substr($ttime,4,0,'-');
## $DBHASH{$timestamp} = sprintf '%s|%s|%s', $idn, $nym,$msg;
my $id = substr($msg,0, index($msg,'|',0) ,'');
warn "something went wrong with $msg, no pipe\n"
if(substr($msg,0,1,'') ne '|'); # kill the next pipe
my $monk = substr($msg,0, index($msg,'|',0) ,'');
warn "something went wrong with $msg, no pipe\n"
if(substr($msg,0,1,'') ne '|'); # kill the next pipe
print start_Tr, start_td;
print font({'-size' => '2'},
a( { href=> $pmurl.'node_id='.$id }, $monk),
br, $ttime
);
print end_td, start_td;
print textarea(-default=>$msg, -rows=>3, -columns=>80);
print end_td, end_Tr;
}
untie %messages;
print end_table, end_form;
print hr,
a( {'href' => "http://validator.w3.org/check/referer"},
img( {'src'=>"/images/valid-html40.png",
'alt'=>"Valid HTML 4.0!",
'border'=>"0",
'height'=>"31",
'width'=>"88"}
)
),
end_html;
}
exit;################################## SUBLAND ######<<<<<<<<<<<<<<<<
+<<<<<<<<|~
##################################### SUBLAND >>>>>>>>>>>>>>>>
+>>>>>>>>|~
=head2 C<&_timestamp>
returns current perlmonks compatible gmtime
=cut
sub _timestamp # current gmtime
{
@_ = (gmtime(time))[5,4,3,2,1,0];
# gimme a slice of that list
$_[0]+=1900; # hey hey, y 2 k
$_[1]+=1; # 0..11 ne 'true month'
return sprintf("%04u-%02u-%02u %02u:%02u:%02u", @_);
}
__END__
|
