#!/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, 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/ && ./cblast35_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 %{$messages}; &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. 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 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 messages, 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 && $dangtimeout); # 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_hashref_b392} undef($raw_xml); # kinda redundant, but i like redundancy 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 Handlers ;-) # 20010723134509 #:) 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 tags $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 next 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 preference 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__