comment on

As promised, here is the code:

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

and the readme:

Security:
    The password database is stored in the clear.  While it would requ
+ire a
    local account and some ingenuity, I strongly suggest you NOT reuse
+ any of
    existing password.  I am not going to explain how, but it is also 
+possible
    for a "bad" person with a local account to wipe out the database(s
+).  If
    the project gets a following, I will take steps to mitigate the ri
+sk.

Stability:
    This is extremely pre-alpha and buggy.  It was my first attempt at
+:
    Parsing XML
    Using MLDBM
    Generating HTML (as you can see by this readme.txt)
    etc.

Names/Passwords:
    Accounts are on a first come first serve basis.  If you have forgo
+tten
    your account/password, you can try /msg Limbic~Region at PerlMonks
+.
    You will not be notified if your login credentials are incorrect. 
+ You
    will simply be returned to the login screen.

Reports:
    There are currently two options for reports.  One allows you to ge
+t any 
    new replies for a thread that you are tracking.  The second allows
+ you to
    get only direct replies to the node.  An important thing to realiz
+e is
    the database will be updated for all children regardless of the re
+port.
    This means if you first try "direct replies" and then "all", you w
+ill
    not likely get anything on the second report.  Even if you do, it 
+will
    only be any newnodes that were added since the last report.  If de
+sired,
    I can fix this.

Content Change:
    Currently, there is no way to determine if a node has changed with
+out 
    storing a checksum.  This would require recursively going through 
+all
    nodes in a thread to determine if there have been any updates.  I 
+don't
    think the added strain is justified.  If this changes, I will like
+ly
    add support if this project gains popularity.

Load for PerlMonks:
    Every time a user adds a node to be tracked or generates a report 
+for a
    tracked node, two calls to PerlMonks is made.  If the "gods" deter
+mine
    this is too much, the project will be shut down immediately.

Bugs/Patches/Comments:
    I am sure there are a lot of bugs.  All bug reports, patches, comm
+ents,
    and suggestions are welcome.  /msg me at PerlMonks

License/Copyright
    Copyright Joshua Gatcomb 2003.  License same as Perl
[download]

Cheers - L~R

In reply to Re: Working Node Tracker? by Limbic~Region
in thread Working Node Tracker? by Limbic~Region

Are you posting in the right place? Check out Where do I post X? to know for sure.
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
Want more info? How to link or How to display code and escape characters are good places to start.