Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

Re: A call for cblast35 mirrors

by pfaut (Priest)
on Dec 11, 2002 at 15:52 UTC ( #219107=note: print w/ replies, xml ) Need Help??


in reply to A call for cblast35 mirrors

I have a modified cblast35 running at http://nbpfaus.net/~pfau/cblast35.cgi. This version has been modified to track chatterboxes on multiple sites. It is currently watching PM and JavaJunkies.

Please be merciful. I only have a DSL connection.

Update: I shut down this mirror a while ago due to site load and the fact that I'm also running the cbhistory mirror.

### 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; # known chatterboxes my %boxes = ( PM => { URL => 'http://www.perlmonks.org/index.pl', DB => 'cb.pm.db', NAME => 'Perl Monks' }, JJ => { URL => 'http://www.javajunkies.org/index.pl', DB => 'cb.jj.db', NAME => 'JavaJunkies' } ); my $html; # D'loop Mayno { $|=1; # ChatterboxXMLTicker my $box = ( split('/',path_info) )[1]; if ( !$box || !exists($boxes{$box}) ) { $html = &show_available_boxes(); } else { my $pmurl = $boxes{$box}{URL} . '?'; my $dbfile = $boxes{$box}{DB}; tie my %messages, 'DB_File', $dbfile, O_RDONLY, 0644, new DB_File::BTREEINFO; $html = start_html('-title' => "$boxes{$box}{NAME} 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}); 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 $html .= start_Tr . start_td; $html .= font({'-size' => '2'}, a( { href=>$pmurl.'node_id='.$id }, $monk), br, $ttime ); $html .= end_td . start_td; $html .= textarea(-default=>$msg, -rows=>3, -columns=>80); $html .= end_td . end_Tr; } untie %messages; $html .= end_table . end_form; $html .= hr . a( {'href' => "http://validator.w3.org/check/referer"}, img( {'src'=>"valid-html40.png", 'alt'=>"Valid HTML 4.0!", 'border'=>"0", 'height'=>"31", 'width'=>"88"} ) ) . end_html; } } print header(-type => 'text/html', -content_length => length($html), -expires => '+5m' ), # cache only for five minutes $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", @_); } sub show_available_boxes { my $html = start_html('-title' => "cb Last 35", '-dtd' => "-//W3C//DTD HTML 4.0 Transitional//EN") . basefont({face => "Arial", size => "2", color => "black"}) . h1('Available Chatterbox Histories') . ul( li( [ map { a({href=>url.'/'.$_},$boxes{$_}{NAME}) } sort ke +ys %boxes ] ) ) . end_html; return $html; } ### cblast35.pl #!/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; # known chatterboxes my %boxes = ( PM => { URL => 'http://www.perlmonks.org/index.pl', DB => 'cb.pm.db' }, JJ => { URL => 'http://www.javajunkies.org/index.pl', DB => 'cb.jj.db' } ); # number of messages to keep use constant HISTORY_SIZE => 35; # it begins foreach (sort keys %boxes) { &update_history($boxes{$_}); }; exit; sub update_history { my $box = shift; my $cbtickerurl = $box->{URL}.'?node=Chatterbox+xml+ticker'; my $dbfile = $box->{DB}; my $semaphore = 'semaphore.'.$dbfile.'.lock'; 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); print "message hash is empty, impossible!!",return unless defined +%{$messages}; &tyebinds($messages,$dbfile,$semaphore); undef $messages; }# it ends ###################################################################### +######## ###### - \ | / ~ \ | / - \ | / ~ \ | / - \ | / ~ \ | / - \ | / ~ 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 $semaphore = shift; 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"); } 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 if &_semaphore($semaphore,1); return 0; } =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 "error $! deleting $fh\n" unless unlink $fh; } } =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; my $dbfile = shift; my $semaphore = shift; unless(&can_i_write($semaphore)) { sleep 5; die "$dbfile is in use at the moment" unless &can_i_write($semaphore) } # 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 > HISTORY_SIZE; } 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 } #!/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; # known chatterboxes my %boxes = ( PM => { URL => 'http://www.perlmonks.org/index.pl', DB => 'cb.pm.db' }, JJ => { URL => 'http://www.javajunkies.org/index.pl', DB => 'cb.jj.db' } ); # number of messages to keep use constant HISTORY_SIZE => 35; # it begins foreach (sort keys %boxes) { &update_history($boxes{$_}); }; exit; sub update_history { my $box = shift; my $cbtickerurl = $box->{URL}.'?node=Chatterbox+xml+ticker'; my $dbfile = $box->{DB}; my $semaphore = 'semaphore.'.$dbfile.'.lock'; 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); print "message hash is empty, impossible!!",return unless defined +%{$messages}; &tyebinds($messages,$dbfile,$semaphore); undef $messages; }# it ends ###################################################################### +######## ###### - \ | / ~ \ | / - \ | / ~ \ | / - \ | / ~ \ | / - \ | / ~ 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 $semaphore = shift; 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"); } 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 if &_semaphore($semaphore,1); return 0; } =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 "error $! deleting $fh\n" unless unlink $fh; } } =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; my $dbfile = shift; my $semaphore = shift; unless(&can_i_write($semaphore)) { sleep 5; die "$dbfile is in use at the moment" unless &can_i_write($semaphore) } # 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 > HISTORY_SIZE; } 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 }


Comment on Re: A call for cblast35 mirrors
Download Code

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (6)
As of 2015-07-04 17: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 (60 votes), past polls