Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

cblast35

by crazyinsomniac (Prior)
on Aug 07, 2001 at 14:18 UTC ( #102736=sourcecode: print w/ replies, xml ) Need Help??

Category: PerlMonks Related Scripts
Author/Contact Info /tell crazyinsomniac or mail him at perlmonk.org
Description: 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?"

It actually is two scripts (well three if you're cronless), cblast35.pl -- which is to be run cron style to update the "database", and cblast35.cgi -- which just displays the messages via CGI.

You can also download everything from my website here

update: A call for cblast35 mirrors has yielded three quite a few mirrors, jay!!!

Thanks blakem,Chady,jeffa ;)
#!/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__

Comment on cblast35
Download Code
Re: cblast35
by PodMaster (Abbot) on Aug 31, 2003 at 12:52 UTC
    Sometimes perlmonks serves up bogus xml ( and XML::Parser chokes on it), so you may wanna use HTML::Parser instead. Instead of creating a XML::Parser object in sub fetch_cb_xml, simply construct a HTML::Parser object like so:
    my $xml_parser = HTML::Parser->new( api_version => 3, unbroken_text => 1, start_h => [ \&_xml_start, 'self,tagname,@attr'], end_h => [ \&_xml_end, 'self,tagname'], text_h => [ \&_xml_char, 'self,text'], xml_mode=> 1, );
    and of course substitute use XML::Parser; with use HTML::Parser; and you're ready to go.

    MJD says "you can't just make shit up and expect the computer to know what you mean, retardo!"
    I run a Win32 PPM repository for perl 5.6.x and 5.8.x -- I take requests (README).
    ** The third rule of perl club is a statement of fact: pod is sexy.

Re: cblast35
by demerphq (Chancellor) on Feb 25, 2006 at 20:53 UTC

    There is also CB60 which provides PM server side linkparsing which means that PM links go to the right place and etc.

    ---
    $world=~s/war/peace/g

Back to Code Catacombs

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others chilling in the Monastery: (10)
As of 2014-08-27 23:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (253 votes), past polls