#!/usr/bin/perl -wT
BEGIN {
use CGI::Carp qw(carpout);
open(LOG, ">>/home/limbicregion/nodetracker/nodetracker.log") or
die("Unable to open nodetracker.log: $!\n");
carpout(LOG);
}
use strict;
use MLDBM qw(DB_File Storable);
use CGI ':standard';
use CGI::Carp 'fatalsToBrowser';
use Fcntl;
use LWP::UserAgent;
use XML::Simple;
my $base = '/home/limbicregion/nodetracker/';
my $pm = 'http://www.perlmonks.org/index.pl?node_id=';
my $user_db = $base . 'user_db';
my $page = param('page') || 'login';
my %dispatch = (
action => \&action,
login => \&login,
main => \&main_page,
);
$dispatch{$page}->();
sub action {
validate_user();
my $db_file = $base . param('username');
tie (my %db, "MLDBM", $db_file, O_CREAT|O_RDWR, 0600)
or die "Can't open $db_file $!\n";
my ($action, $node) = (param('action'), param('node'));
die "Something went terribly wrong" if ! $action;
if ($action eq 'Add Tracked Node') {
if (! $db{$node}) {
my ($tree, $success) = get_node_tree($node);
$db{$node} = $tree if $success;
}
set_main();
print redirect(self_url);
}
elsif ($action eq 'Delete Tracked Node') {
delete $db{ param('node') };
set_main();
print redirect(self_url);
}
elsif ($action eq 'List Tracked Node(s)') {
set_main();
gen_report(\%db, "Tracked Nodes", \%db, 1);
}
else {
set_main();
if ($db{$node}) {
my ($temp, $success) = get_node_tree($node);
my %changes;
my (@old_nodes, @new_nodes);
if (param('direct_only')) {
@old_nodes = @{ $db{$node}{base_nodes} };
@new_nodes = @{ $temp->{base_nodes} };
}
else {
@old_nodes = grep /^\d+$/, keys %{$db{$node}};
@new_nodes = grep /^\d+$/, keys %{$temp};
}
@changes{@new_nodes} = ();
delete @changes{@old_nodes};
my $title = "New Replies for " . a( { href=>"$pm$node"},
+$node);
gen_report(\%changes, $title, $temp);
$db{$node} = $temp if $success;
}
else {
print redirect(self_url);
}
}
}
sub build_keys {
my ($tree, $record) = @_;
for my $key (keys %{$tree}) {
if ($key eq 'id') {
$record->{$tree->{id}} = {};
}
elsif ($key =~ /^\d+$/) {
$record->{$key} = {};
build_keys ($tree->{$key}, $record);
}
elsif ($key eq 'node') {
build_keys ($tree->{'node'}, $record);
}
}
}
sub gen_report {
my ($hash, $title, $db, $fudge) = @_;
print header,
start_html( -title => 'PerlMonks Node Tracker', -bgcolor => "#ffff
+cc" ),
div( { -align => "center" },
h1($title),
p(
a( { href=>self_url}, "Main Menu" ),
),
table(
{
-bgcolor => "#000000",
-border => "0",
-cellpadding => "2",
-cellspacing => "1",
},
Tr( { -style => "background-color:#CCCCCC" },
th( ['Node', 'Description', 'Author', 'Node Type', 'Cr
+eated'] ),
),
Tr( { -style => "background-color:#CCCCCC" },
[
map {
my $r = $fudge ? $db->{$_}{$_} : $db->{$_};
td([
a({href=>"${pm}$_", target=>'_blank'}, $_),
$r->{content},
a({href=>"${pm}$r->{author_user}", target=>'_b
+lank'}, $r->{author_name}),
$r->{nodetype},
$r->{createtime},
])
} sort keys %{$hash}
]
),
),
p(
a( { href=>self_url}, "Main Menu" ),
),
),
end_html;
}
sub get_node_tree {
my $node = shift;
my $UA = LWP::UserAgent->new;
my $url_1 = $pm . '180684&id=' . $node;
my $response = $UA->request(HTTP::Request->new(GET => $url_1));
die "Unable to contact PerlMonks" if ! $response->is_success;
my $tree = XMLin($response->content);
my %record;
$record{base_nodes} = [ keys %{$tree->{node}} ] if $tree->{node};
build_keys($tree, \%record);
my @nodes = grep /^\d+$/, keys %record;
my $url_2 = $pm . '37150&nodes=';
$url_2 .= join ',' , @nodes;
$response = $UA->request(HTTP::Request->new(GET => $url_2));
die "Unable to contact PerlMonks" if ! $response->is_success;
$tree = XMLin($response->content);
if (ref $tree->{NODE} eq 'ARRAY') {
for my $entry (@{$tree->{NODE}}) {
$record{$entry->{node_id}} = $entry;
}
}
else {
$record{$node} = $tree->{NODE};
}
return \%record, $record{$node}->{lastupdate} ? 1 : 0;
}
sub login {
print header,
start_html( -title => 'PerlMonks Node Tracker', -bgcolor => "#ffff
+cc" ),
div( { -align => "center" },
h1( "Login to your account" ),
start_form(
{
-action => "nodetracker.cgi",
-enctype => "application/x-www-form-urlencoded",
-method => "post"
}
),
table(
{
-bgcolor => "#000000",
-border => "0",
-cellpadding => "2",
-cellspacing => "1",
},
Tr( { -style => "background-color:#CCCCCC" },
td( strong( "User Name:" ) ),
td( input( {
-maxlength => "30",
-name => "username",
-size => "30",
-type => "text"
} ), ),
),
Tr( { -style => "background-color:#CCCCCC" },
td( strong( "Password:" ) ),
td( input( {
-maxlength => "30",
-name => "password",
-size => "30",
-type => "password"
} ), ),
),
Tr(
td( { -colspan => "2", -style => "background-color:#CC
+CCCC" },
input ( { -name => "newaccount", -type => "checkbo
+x" } ),
" New Account ",
),
),
),
p(
input( { -type => "submit", -value => "Login" } ),
" ",
input( {-type => "reset" } ),
" ",
input( { -type => "hidden", -name => "page", -value => "ma
+in" } ),
),
a( { href=>"readme.txt", target=>"_blank"}, "Help" ),
end_form,
),
end_html;
}
sub main_page {
new_account() if param('newaccount');
validate_user();
print header,
start_html( -title => 'PerlMonks Node Tracker', -bgcolor => "#ffff
+cc" ),
div( { -align => "center" },
h1( "Main Menu" ),
start_form(
{
-action => "nodetracker.cgi",
-enctype => "application/x-www-form-urlencoded",
-method => "post"
}
),
table(
{
-bgcolor => "#000000",
-border => "0",
-cellpadding => "2",
-cellspacing => "1",
},
Tr( { -style => "background-color:#CCCCCC" },
td( strong( "Action:" ) ),
td( scrolling_list(
-name => 'action',
-values => [
'Add Tracked Node',
'Delete Tracked Node',
'List Tracked Node(s)',
'Report Tracked Node',
],
-size => 1,
-default => 'Report Tracked Node',
), ),
),
Tr( { -style => "background-color:#CCCCCC" },
td( strong( "Node ID:" ) ),
td( input( {
-maxlength => "6",
-name => "node",
-size => "7",
-type => "text"
} ), ),
),
Tr(
td( { -colspan => "2", -style => "background-color:#CC
+CCCC" },
input ( { -name => "direct_only", -type => "checkb
+ox" } ),
" Direct Replies Only ",
),
),
Tr(
td( { -colspan => "2", -style => "background-color:#CC
+CCCC" },
input ( {
-name => "updates",
-type => "checkbox",
-disabled => 1,
} ),
" Content Change/Update ",
),
),
),
p(
input( { -type => "submit", -value => "Do it" } ),
" ",
input( {-type => "reset" } ),
" ",
input(
{
-type => "hidden",
-name => "password",
-value => param('password')
}
),
" ",
input(
{
-type => "hidden",
-name => "username",
-value => param('username')
}
),
" ",
input(
{
-type => "hidden",
-name => "page",
-value => "action",
}
),
),
a( { href=>"readme.txt", target=>"_blank"}, "Help" ),
end_form,
),
end_html;
}
sub new_account {
tie (my %user, "MLDBM", $user_db, O_CREAT|O_RDWR, 0600)
or die "Can't open $user_db: $!\n";
my ($name, $pass) = (param('username'), param('password'));
if (! $user{$name}) {
$user{$name} = $pass;
return;
}
print header,
start_html( -title => 'PerlMonks Node Tracker', -bgcolor => "#ffff
+cc" ),
div( { -align => "center" },
h1( "Sorry - Account already exists" ),
p(
a( { href=>"nodetracker.cgi"}, "Try Again?" ),
" ",
a( { href=>"readme.txt", target=>"_blank"}, "Help" ),
),
),
end_html;
exit;
}
sub set_main {
param('action' => 'Report Tracked Node');
param('page' => 'main');
}
sub validate_user {
tie (my %user, "MLDBM", $user_db, O_CREAT|O_RDWR, 0600)
or die "Can't open $user_db: $!\n";
my ($name, $pass) = (param('username'), param('password'));
return if $user{$name} && $user{$name} eq $pass;
print redirect("nodetracker.cgi");
}
close LOG;