#!/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__
[download]