#!/usr/bin/perl -w
#
# $Id: bb-track.pl,v 1.7 2003/01/23 18:33:51 jmates Exp $
#
# Copyright (c) 2001-2003, Jeremy Mates.  This script is free software;
# you can redistribute it and/or modify it under the same terms as
# Perl itself.
#
# Run perldoc(1) on this file for additional documentation.
#
######################################################################
#
# REQUIREMENTS

require 5;

use strict;

######################################################################
#
# MODULES

use Carp;           # better error reporting
use Getopt::Std;    # command line option processing

use Data::Dumper;				# DBG

use LWP::Simple;

use Tk;

######################################################################
#
# VARIABLES

my $VERSION;
($VERSION = '$Revision: 1.7 $ ') =~ s/[^0-9.]//g;

my (%opts);

# how often to check for updates (seconds)
my $update = 117;

# mapping of key events...
my %key_table = (
				 q => sub { $_[0]->destroy },
				 Q => sub { $_[0]->destroy },
				 );

# default window size
my $geometry = '50x50';

######################################################################
#
# MAIN

# parse command-line options
getopts('h?g:', \%opts);

help() if exists $opts{'h'} or exists $opts{'?'};

$geometry = $opts{'g'} if exists $opts{'g'};

my $target = shift;

my $main = MainWindow->new();

# TODO see if this works to remove all decorations
#$main->overrideredirect(1);

# dunno if need to set all these
$main->title("BBTrack");
$main->client("BBTrack");
$main->iconname("BBTrack");

$main->geometry($geometry);

$main->bind("<Key>", [ \&handle_key, Ev('K') ]);

# fiddle with update so multiple clients don't all check in step
$update += int(rand 20) - 10;

$main->repeat($update * 1000, \&hit_website);

&hit_website;

MainLoop;

exit;

######################################################################
#
# SUBROUTINES

# visit BB webpage, nab content, update color as required
sub hit_website {
	my $content = get($target);
	
	# probably should have some means if indicating that there
	# was a problem contacting remote website...
	unless ($content) {
		$main->bell();
		$main->configure(-background => "grey");
		return;
	}

	my $status;
	($status) = $content =~ /<body[^>]+?bgcolor\W+?([a-z]+)/i;

	if ($status ne 'green') {
		warn "Non green: ", $status, "\n";
		$main->bell();
	}
	$main->configure(-background => $status);
}

# for handling key presses and stuff
sub handle_key {
	if (exists $key_table{$_[1]} and ref $key_table{$_[1]} eq 'CODE') {
		&{$key_table{$_[1]}};
	}
}

# a generic help blarb
sub help {
    print <<"HELP";
Usage: $0 [opts]

Help for a generic script template.

Options for version $VERSION:
  -h/-?  Display this message

Run perldoc(1) on this script for additional documentation.

HELP
    exit;
}

######################################################################
#
# DOCUMENTATION

=head1 NAME

bb-track.pl - displays Big Brother website color in Tk window

=head1 SYNOPSIS

Run in 50 by 50 pixel window against Big Brother page at the specified
location.

  $ bb-track.pl -g 50x50+0-0 http://www.example.org/bb/

=head1 DESCRIPTION

=head2 Overview

Displays a window on any system that supports Tk that has a background
color reflecting that on a Big Brother monitoring page.  Not green is
bad, and the script will beep.

=head2 Normal Usage

  $ blank.pl [options] URL

See L<"OPTIONS"> for details on the command line switches supported.

=head1 OPTIONS

This script currently supports the following command line switches:

=over 4

=item B<-h>, B<-?>

Prints a brief usage note about the script.

=back

X11 geometry options can be passed in on the command line as well.

=head1 ENVIRONMENT

Requires Tk, LWP perl modules to be available.

=head1 BUGS

=head2 Reporting Bugs

Newer versions of this script may be available from:

http://sial.org/code/perl/

If the bug is in the latest version, send a report to the author.
Patches that fix problems or add new features are welcome.

=head2 Known Issues

No known bugs.

=head1 SEE ALSO

perl(1)

=head1 AUTHOR

Jeremy Mates, http://sial.org/contact/

=head1 COPYRIGHT

Copyright (c) 2001-2003, Jeremy Mates.  This script is free software;
you can redistribute it and/or modify it under the same terms as Perl
itself.

=head1 VERSION

  $Id: bb-track.pl,v 1.7 2003/01/23 18:33:51 jmates Exp $

=cut