Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??

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 }

In reply to Re: A call for cblast35 mirrors by pfaut
in thread A call for cblast35 mirrors by crazyinsomniac

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others lurking in the Monastery: (5)
    As of 2015-07-01 22:20 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 (24 votes), past polls