http://www.perlmonks.org?node_id=69580
Category: PerlMonks Related Scripts
Author/Contact Info epoptai
Description: reputer is a perl/cgi that analyzes and displays node reputation and xp data from perlmonks.

Because it's larger than 50k reputer has two nodes on Perlmonks.
This is the source code node in code catacombs.
Please make replies to the reply node.

Also includes proxy support, restricted public access mode,
integration with command line programs and compressed file export.

Update: Fixed possible problem creating data files when first running script.

#!perl -T
# reputer analyzes and displays node reputation and xp data from perlm
+onks.org 
# homenode = http://perlmonks.org/index.pl?node=reputer
#
# List user nodes sorted by rep, title or date in HTML tables.
# Three ways to graph number of nodes by reputation.
# Display changed, deleted and new node info and rep change.
# Cookies save info used for lwp transfers, and display options.
# Can write up to 8 data files in temp dir, so give it write permissio
+n.
#
# Export/import enabled if Compress::Zlib is installed
# Requires XML::Simple

use strict;
use CGI qw(header param url);
eval("use XML::Simple 'XMLin'"); # required xml parser
if($@){&install_xml_simple(); exit}
use CGI::Cookie;
use HTTP::Cookies;
use HTTP::Request::Common;
use HTML::Entities 'encode_entities';
use LWP::Simple 'get';
use LWP::UserAgent qw(agent cookie_jar request content);
use Data::Dumper;
#use CGI::Carp 'fatalsToBrowser'; # only use for debugging with -w

my$trade = 0;
eval("use Compress::Zlib"); 
unless($@){$trade = 1} # if installed enable export/import

# config variables
my$temp = './'; # where data files are saved
my$public_access = ''; # 'yes' disables config, downloads, and externa
+l program functions
my$bodytag = '<body bgcolor="#aaaaaa" text="#000000">';
my$form_method = 'get'; # get or post, 'get' shows params in url
my%programs = ( # full path to optional external programs, links will 
+appear in sort mode.
# key = the display name, value = a system call which dumps output to 
+the browser.
# 'xrepwalker' => 'perl xlukerep.pl',
# 'xstatswhore' => 'perl xstatswhore.pl',
# 'tracert perlmonks' => 'tracert perlmonks.org',
# 'ping perlmonks' => 'ping perlmonks.org',
);
# proxy
my$use_proxy = ''; # 'yes' enables use thru the following proxy
my$proxy = 'http://proxy.dom:port'; # must define this to use proxy
my$proxyid   = '';
my$proxypass = '';
# end config variables

my$bb = 0; # table border on node list
if($ENV{'HTTP_USER_AGENT'}){ # ie cant do cellspacing as border in nes
+ted colored tables
if(($ENV{'HTTP_USER_AGENT'}=~/MSIE/) || ($ENV{'HTTP_USER_AGENT'}!~/Moz
+illa/)){ $bb = 1 }}
my$perlmonks = ''; # default for links if no cookie set
my$ddi = 0; # data dumper intent level, 0 = smallest files

# paths and data files
my$df = $temp.'reputer.dat'; # main data file
my$repthen = $temp.'reputer.then'; # 'previous' rep file
my$repnow = $temp.'reputer.now'; # 'present' rep file
my$uri = url();

# html elements
my$nb = '&nbsp;';
my$bq = '<blockquote>';
my$eh = '</body></html>';
my$metac = "<meta http-equiv='refresh' content='1;url=$uri?n=changes'>
+";
my$metad = "<meta http-equiv='refresh' content='1;url=$uri?n=config'>"
+;

# general vars
my$handle = select();
my$today = localtime(time);
my%cookies = CGI::Cookie->fetch();
my%i = map{$_ => param($_)} param;
my%info = ( version => '1.0', date => '20010404' );
my($fix_title,$strip_re) = '';

# sort mode descriptions
my%modescs = (
    ta => 'Title',
    td => 'Title Reverse',
    ra => 'Lowest Reputation First',
    rd => 'Highest Reputation First',
    ca => 'Oldest First',
    cd => 'Newest First'
    );

if(($i{'exec'}) && ($public_access ne 'yes')){ # external programs
    if(($ENV{PATH}) && ($ENV{PATH}=~/(.*)/s)){$ENV{PATH}=$1} # get tai
+nt to accept our path
    if(exists $programs{$i{'exec'}}){
        for(keys %programs){
            if($_ eq $i{'exec'}){
                my$status = system("$programs{$_}");
                die "$programs{$_} failed: $?" unless $status == 0;
                }
            }
        }
    else{ print header; print "Can't find <i>$i{'exec'}</i> in program
+ list."}
    exit
    }

if(($i{'erase'}) && ($public_access ne 'yes')){  # delete data files
    if($i{'erase'} eq 'current'){&erase($repnow,$repthen); exit}
    if($i{'erase'} eq 'backup'){&erase("$repnow.bak","$repthen.bak"); 
+exit}
    if($i{'erase'} eq 'safe'){&erase("$repnow.safe","$repthen.safe"); 
+exit}
    }

# var names for 3 required files below
use vars qw($xpdat1 $dat1 $then1 $thenxp1 $thent $now1 $nowxp1 $nowt);
+ 

# read from main data file if it exists, otherwise read from the netwo
+rk.
my$nodat = 0;
my($xpdata,$data,$md); # vars for next block
    if(eval "require '$df'"){ # offline mode
        $md = (stat($df))[9];
        $md = sprintf "<b>Data file updated:</b>  %s<br>", scalar loca
+ltime($md);
        $xpdata = $xpdat1; # hash containing parsed xp xml
        $data = $dat1; # hash containing parsed usernodes xml
        }
    else{$nodat = 1} # online mode
# previous rep file
my($then,$thenxp,$thentime,$then_is);
if(($i{'n'}) && ($i{'n'} eq 'changes')){ 
    if(eval "require '$repthen'"){ # old rep file
        $then_is = 1;
        $then = $then1; 
        $thenxp = $thenxp1; 
        $thentime = $thent; 
        }
    }
# present rep file
my($now,$nowxp,$nowtime,$now_is);
if(($i{'n'}) && ($i{'n'} eq 'changes')){
    if(eval "require '$repnow'"){ # new rep file
        $now_is = 1;
        $now = $now1; 
        $nowxp = $nowxp1; 
        $nowtime = $nowt; 
        }
    }

my$ins = 0;
if(($i{'n'}) && ($public_access ne 'yes')){
    if($i{'n'} eq 'dumphash'){&dump_hash(); exit} # display raw data s
+tructure
    if($i{'n'} eq 'login'){
        if($i{'user'}){$ins++}
        if($i{'pass'}){$ins++}
        if($i{'pm'}){$ins++}
        if($i{'show'}){$ins++}
        }
    }
if( ($i{'n'}) && ($public_access ne 'yes') ){ # set cookies if logout 
+or login
    if( ( ($i{'n'} eq 'login') && ($ins > 0) ) || ($i{'n'} eq 'logout'
+) ){
        my($c1,$c2,$c3,$c4,$s) = '';
        if($i{'n'} eq 'login'){
            if($i{'pm'}=~m|^(http://)|i){$i{'pm'}=~s/$1//o}
            $c1 = CGI::Cookie->new(-name=>'user',-value=>"$i{'user'}",
+-expires=>'+10y');
            $c2 = CGI::Cookie->new(-name=>'pass',-value=>"$i{'pass'}",
+-expires=>'+10y');
            $c3 = CGI::Cookie->new(-name=>'pm',-value=>"$i{'pm'}",-exp
+ires=>'+10y');
            $c4 = CGI::Cookie->new(-name=>'show',-value=>"$i{'show'}",
+-expires=>'+10y');
            }
        if($i{'n'} eq 'logout'){
            $c1 = CGI::Cookie->new(-name=>'user',-value=>'',-expires=>
+'now');
            $c2 = CGI::Cookie->new(-name=>'pass',-value=>'',-expires=>
+'now');
            $c3 = CGI::Cookie->new(-name=>'pm',-value=>'',-expires=>'n
+ow');
            $c4 = CGI::Cookie->new(-name=>'show',-value=>'',-expires=>
+'now');    
            }
        print header(-cookie=>[$c1,$c2,$c3,$c4]);
    
        unless($i{'n'} eq 'logout'){
            if($ins > 1){$s='s'}
            &begin_html('fu');
            print qq~$bq $bq $bq
            <h2>Cookie$s set</h2><b>
            username:</b> $i{'user'}<br><b>
            password:</b> <font size="-1">$i{'pass'}</font><br><b>
            perlmonks:</b> <a href="http://$i{'pm'}">$i{'pm'}</a><br><
+b>
            nodes per page:</b> $i{'show'}<br>~;
            my$err = 0;
            if( (!$i{'user'}) or (!$i{'pass'}) or (!$i{'pm'}) ){
                print qq~<p><b><font color="#FF0000">Warning:</font> R
+equired data missing!</b><ol>~;
                if(!$i{'user'}){ print '<li><b>username</b> required t
+o access perlmonks.<br>'}
                if(!$i{'pass'}){ print '<li><b>password</b> required t
+o access perlmonks.<br>'}
                if(!$i{'pm'}){ print '<li><b>perlmonks</b> domain requ
+ired to access perlmonks.<br>'}
                print '</ol>';
                $err++
                }
            unless(($i{'pm'}) && ($i{'pm'}=~/\..*?\./)){ 
                print qq~<p><font color="#FF0000"><b>Error</b>:</font>
+ <b>perlmonks</b> 
                domain must have two dots!.~;
                $err++
                }
            if( (!$i{'show'}) || (($i{'show'}) && ($i{'show'}!~/\d+/))
+ ){
                print qq~<p><font color="#FF0000"><b>Caution</b>:</fon
+t> setting <b>nodes 
                per page</b> to &lt; 1 or blank shows <i>all</i> nodes
+.~;
                $err++
                }
            if($nodat == 1){ 
                print qq~<p><font color="#FF0000"><b><b>Data file not 
+detected.</b></b></font> 
                <a href="$uri?n=make+data">Build a data file</a>?~;
                $err++
                }
            if($err > 0){
                print qq~<form method="$form_method">
                <input type="hidden" name="n" value="login">
                <input type="submit" value="login form"></form>~;
                }
            print qq~<p><font size="-1"><b>Note:</b> Setting a cookie 
+with incorrect username,
            password or perlmonks domain is fatal to authenticated dow
+nloads (online mode 
            functions: refresh and file creation) and will prompt to r
+etry or login again. Bad 
            login cookies do not interfere with offline operations.</f
+ont>~;
            if($cookies{'ft'}){$fix_title = $cookies{'ft'}->value}
            if($cookies{'sr'}){$strip_re = $cookies{'sr'}->value}
            &print_form('z'); # print nav buttons, any arg just kicks 
+it into another mode
            print $eh; # end_html
            exit
            }
        }
    }
my($username,$password,$show) = '';

if($public_access ne 'yes'){
    if(($i{'n'}) && ($i{'n'} eq 'logout')){&login_form(); exit}
    }
if(%cookies){ # get cookies
    if($cookies{'user'}){$username = $cookies{'user'}->value}
    if($cookies{'pass'}){$password = $cookies{'pass'}->value}
    if($cookies{'pm'}){$perlmonks = $cookies{'pm'}->value}
    if($cookies{'show'}){$show = $cookies{'show'}->value}
    if($cookies{'ft'}){$fix_title = $cookies{'ft'}->value}
    if($cookies{'sr'}){$strip_re = $cookies{'sr'}->value}
    }

my$start = 1;
if(($i{'start'}) && ($i{'start'}=~/\d+/)){$start = $i{'start'}}
if(($i{'show'}) && ($i{'show'}=~/\d+/)){$show = $i{'show'}}
if(defined($i{'ft'})){$fix_title = $i{'ft'}}
if(defined($i{'sr'})){$strip_re = $i{'sr'}}

# urls
my$pmurl  = "http://$perlmonks/index.pl";
my$repurl = "$pmurl?node_id=32704";
my$xpurl  = "$pmurl?node_id=16046";

if($i{'n'}){
    if($i{'n'} eq ' ? '){&help(); exit}
    if($public_access ne 'yes'){
        if($i{'n'} eq 'update'){&check_update(); exit}
        if(($i{'n'} eq 'login') && ($ins < 1)){&begin_html(); &login_f
+orm(); exit}
        if(($i{'n'} eq 'config') && ($nodat == 1)){&begin_html(); &con
+fig(); exit}
        }
    }
my($xml,$repxml,$xpxml,$avgrep,$modesc);
# if data file doesn't exist or is being created or refreshed read xml
+ from network
if( ($public_access ne 'yes') && ( ($nodat == 1) || ( ($i{'n'}) && ($i
+{'n'}=~/make data/) ) ) ){ 
    unless(($username=~/\S/) && ($password=~/\S/)){
        &begin_html(); &login_form(); exit
        }
    &login(); # returns $repxml and $xpxml
    &fixxml($xpxml); # returns $xml
    $xpdata = XMLin($xml, keyattr => 'XP', forcearray => 1);
    &fixxml($repxml); # returns $xml
    $data = XMLin($xml, keyattr => 'NODE', forcearray => 1);
    }

# extract xp info and username
my($xp,$level,$xp2next,$xusername);
if(defined @{$xpdata->{'XP'}}){
    for my $xpinfo(@{$xpdata->{'XP'}}){
        $xp2next = $xpinfo->{'xp2nextlevel'};
        $level = $xpinfo->{'level'};
        $xp = $xpinfo->{'xp'};
        }
    }
if(defined @{$xpdata->{'INFO'}}){
    for my $xpinfo(@{$xpdata->{'INFO'}}){
        $xusername = $xpinfo->{'foruser'};
        }
    }

my$begin_html = 0; # init header check
my($mode,$td,$ta,$rd,$ra,$ca,$cd) = '';
if($i{'n'}){
    # sub calls
    unless($public_access eq 'yes'){
        if($i{'filename'}){
            if($i{'n'} eq 'import data'){&import(); exit}
            }
        if($i{'n'} eq 'import'){&import_data(); exit}
        if($i{'n'} eq 'export'){&export_data(); exit}
        }
    if($i{'n'} eq 'gif'){&gif(); exit}
    # sort modes
    if($i{'n'} eq 'td'){$mode=$i{'n'}; $td='selected'} # title reverse
    if($i{'n'} eq 'ta'){$mode=$i{'n'}; $ta='selected'} # title
    if($i{'n'} eq 'rd'){$mode=$i{'n'}; $rd='selected'} # highest rep f
+irst
    if($i{'n'} eq 'ra'){$mode=$i{'n'}; $ra='selected'} # lowest rep fi
+rst
    if($i{'n'} eq 'ca'){$mode=$i{'n'}; $ca='selected'} # oldest first
    if($i{'n'} eq 'cd'){$mode=$i{'n'}; $cd='selected'} # newest first
    if($i{'n'} eq 'graph'){$mode='rd'; $rd='selected'} # graph - highe
+st rep first
    }
else{$mode='cd'; $cd='selected'} # default to newest first if no input
my(%node_reps,%node_rep,%node_con,%node_cre,%rep_freq,%node_home);
my(@reps,@reps_nodes,$total_nodes,$total_rep,$homenode);
if(defined @{$data->{'NODE'}}){
    my(@negs,@titles,@dates,$usersince);

    for my $node(@{$data->{'NODE'}}){ # find homenode
        $node_home{$node->{'id'}}=1
        }
    my@hn = sort {$a <=> $b} keys %node_home; 
    $homenode = $hn[0]; # by lowest node id

    for my $node(@{$data->{'NODE'}}){
        if($node->{'id'} == $homenode){
            $usersince = $node->{'createtime'}
            }
        unless($node->{'id'} == $homenode){
            $rep_freq{$node->{'reputation'}}++; # frequency hash
            if($fix_title eq 'yes'){
                $node->{'content'} =~ s/\($username\)//g; # strip user
+name from node title
                }
            $node_con{$node->{'id'}}  = $node->{'content'};
            $node_cre{$node->{'id'}}  = $node->{'createtime'};
            $node_rep{$node->{'id'}}  = $node->{'reputation'};
            $node_reps{$node->{'id'}} = $node->{'reputation'};
            $total_rep += $node->{'reputation'}; # total rep
            $total_nodes++;
            }
        }

    for(sort {$node_rep{$b} <=> $node_rep{$a}} keys %node_rep){
        push @reps, $node_rep{$_}; # build a sorted array of node reps
        push @reps_nodes, $_; # and a parallel array of corresponding 
+node_ids
        }
    my$rephi = $reps[0];
    my$replo = $reps[-1];

    if(($i{'n'}) && ($public_access ne 'yes')){ # bailout before html 
+header
    if(($i{'n'} eq 'detect change') or ($i{'n'} eq 'detect')){&detect_
+changed_nodes(); exit}
    if(($i{'n'} eq 'restore') or ($i{'n'} eq 'restore previous')){&res
+tore(); exit}
    if ($i{'n'} eq 'safe backup'){&safety('backup'); exit}
    if ($i{'n'} eq 'safe restore'){&safety('restore'); exit}
    }

    if(($show < 1) || ($show eq '')){$show = $total_nodes}
    if(($start < 1) || ($start eq '')){$start = 1}

    unless(($i{'re'}) && ($i{'re'}==1)){
    &begin_html(); # html header, html start tags
    &the_bridge($total_rep,$xp,$rephi,$replo,$usersince); # display th
+e summary and menu
    }
    if($i{'n'}){ # bailout after html header
        unless($public_access eq 'yes'){
            if(($i{'n'} eq 'make data') || ($nodat == 1)){&makedat(); 
+exit}
            if($i{'n'} eq 'config'){&config(); exit}        
            }
        if($i{'n'} eq 'changes'){&nowthen(); exit}
        if($i{'n'} eq 'graph'){&graph(); 
        &the_bridge($total_rep,$xp,$rephi,$replo,$usersince); print $e
+h; exit}
        }
    for(keys %modescs){ # find description of current sort mode
        if($_ eq $mode){
            $modesc = $modescs{$mode}
            }
        }
    my($c,$d);

    if($mode=~/rd|ra/){ # by rep
        &listitle(); # print title corresponding to sort mode, opens t
+able
        print qq~<tr bgcolor="#ffffff">
        <td>num</td><td>title</td><td><b>rep</td><td>date</td></tr>~; 
+       
        if($mode=~/ra/){ # ascend
            @reps = reverse(@reps);
            @reps_nodes = reverse(@reps_nodes);
            } 
        my$r = '-1';
        for(@reps){
            $r++;
            $c++;
            if($c >= $start){
                $d++;
                unless($d > $show){
                if($strip_re eq 'yes'){$node_con{$reps_nodes[$r]}=~s/R
+e: //g}
                    print qq~<tr><td>$c</td>
                    <td><a href='$pmurl?node_id=$reps_nodes[$r]'>$node
+_con{$reps_nodes[$r]}</a></td>
                    <td>$_</td>
                    <td>$node_cre{$reps_nodes[$r]}</td></tr>~;
                    }
                }
            }
        &nodes_per_page($start,$show,$c);
        }

    if($mode=~/td|ta/){ # by title
        &listitle();
        print qq~<tr bgcolor="#ffffff">
        <td>num</td><td><b>title</td><td>rep</td><td>date</td></tr>~;
        for(keys %node_con){ 
            if($strip_re eq 'yes'){$node_con{$_}=~s/Re: //g}
            push @titles, $node_con{$_}."\t".$_
            }
        if($mode=~/td/){@titles = sort { lc($b) cmp lc($a) } (@titles)
+} # descend
        if($mode=~/ta/){@titles = sort { lc($a) cmp lc($b) } (@titles)
+} # ascend
        for(@titles){
            $c++;
            if($c >= $start){
                $d++;
                unless($d > $show){
                    my($k,$v)=split(/\t/,$_);            
                    print qq~<tr><td>$c</td>
                    <td><a href="$pmurl?node_id=$v">$k</a></td>
                    <td align="right">$node_reps{$v}</td>
                    <td>$node_cre{$v}</td></tr>~;
                    }
                }
            }
        &nodes_per_page($start,$show,$c);
        }

    if($mode=~/cd|ca/){ # by date
        &listitle();
        print qq~<tr bgcolor="#ffffff">
        <td>num</td><td>title</td><td>rep</td><td><b>date</td></tr>~;
        for(keys %node_cre){ push @dates, $node_cre{$_}."\t".$_}
        if($mode=~/cd/){@dates = sort { lc($b) cmp lc($a) } (@dates)} 
+# descend
        if($mode=~/ca/){@dates = sort { lc($a) cmp lc($b) } (@dates)} 
+# ascend
        for(@dates){
            $c++;
            if($c >= $start){
                $d++;
                unless($d > $show){
                    my($k,$v)=split(/\t/,$_);
                    if($strip_re eq 'yes'){$node_con{$v}=~s/Re: //g}
                    print qq~<tr><td>$c</td>
                    <td><a href='$pmurl?node_id=$v'>$node_con{$v}</a><
+/td>
                    <td align='right'>$node_reps{$v}</td>
                    <td>$node_cre{$v}</td></tr>~;
                    }
                }
            }
        &nodes_per_page($start,$show,$c);
        }
    &the_bridge($total_rep,$xp,$rephi,$replo,$usersince);
    print $eh;
    exit
    }

sub nodes_per_page
{ # construct the 'previous' and 'next' paging links
my($start,$show,$c) = @_;
my$previous = ($start-$show);
print '</td></tr></table><div align="center"><table border="0"><tr><th
+>';
unless($previous < 1){ # previous n
    print qq~<font size="-1"><a href="$uri?n=$mode&start=$previous&sho
+w=$show~;
    if($fix_title eq 'yes'){ print qq~&ft=yes~}
    if($strip_re eq 'yes'){ print qq~&sr=yes~}
    print qq~">&lt;&lt; Prev $show</a></font>&nbsp;~;
    }
my$Next = ($start+$show);
# start and show form
print qq~</th><form method="$form_method"><th align="right">
<input type="text" name="start" value="$start" size="3">
<input type="hidden" name="show" value="$show">
<input type="hidden" name="n" value="$mode">
</th></form><form method="$form_method"><th>
<input type="text" name="show" value="$show" size="3">
<input type="hidden" name="start" value="$start">
<input type="hidden" name="n" value="$mode"></th></form><th>~;
unless($Next > $c){ # next n
    print qq~&nbsp;<font size="-1"><a href="$uri?n=$mode&start=$Next&s
+how=$show~;
    if($fix_title eq 'yes'){ print qq~&ft=yes~}
    if($strip_re eq 'yes'){ print qq~&sr=yes~}
    print qq~">Next $show &gt;&gt;</a></font>~;
    }
print qq~<br></th></tr><tr><td colspan="2" align="right" valign="top">
+start </td>
<td colspan="2" valign="top">show</td></tr></table></div><p>~;
}

sub login_form
{
my$state = shift;
&begin_html('fu');
print qq~<form method="$form_method">$bq <h1>Login</h1>~;
if($state eq 'config'){ 
    print qq~<b>reputer creates 4 browser cookies</b><p>
    <b>1. username, 2. password,</b> and <b>3. perlmonks</b> are requi
+red 
    to read rep and xp data from the network, but aren't used when wor
+king 
    with saved files. <b>4. nodes per page</b> sets the page limit for
+ the 
    sorted node list. If blank or set to 0 or less than 1 it shows all
+ 
    nodes. Set a reasonable limit if you have a large number of nodes.
+~;
    }
unless($state eq 'config'){ 
    print qq~Enter your <b>username, password</b> and <b>perlmonks</b>
+ domain here 
    and select login. This saves browser cookies and prompts you to re
+load 
    reputer, which then uses the cookie info for further interaction w
+ith 
    perlmonks. The <b>'nodes per page'</b> cookie defines the length o
+f the node 
    list. Logout deletes these browser cookies.<p>
    <font size="-1">Note: username, password and perlmonks domain are 
+required 
    to acquire data.</font>~;
    }
if(($username!~/\S/) || ($password!~/\S/)){
    unless(($i{'n'}) && ($i{'n'} eq 'logout')){
        print '<p><font color="#ff0000"><b>Warning:</b></font><ol>';
        unless($username=~/\S/){ print "<li>username required"}
        unless($password=~/\S/){ print "<li>password required"}
        unless($perlmonks=~/^.*?\..*?\..*?$/){ print "<li>perlmonks do
+main required (with two dots)"}
        }
    }
print qq~<p>
<input type="text" name="user" size=22 value="$username"> <b>username<
+/b><br>
<input type="text" name="pass" size=22 value="$password"> <b>password<
+/b><br><p>
<font size="-1">Set to your usual login domain.<br></font>
<input type="text" name="pm" size=22 value="$perlmonks"> <b>perlmonks<
+/b><br>
<font size="-1">Must have at least two dots.<br></font><p>
<input type="text" name="show" size="3" value="$show"> <b>nodes per pa
+ge</b><br>
<input type="submit" name="n" value="login"> 
<input type="submit" name="n" value="logout">~;
if(($i{'n'}) && ($i{'n'} ne 'config')){ print ' <input type="submit" n
+ame="n" value=" ? ">'}
print "</form></blockquote> $eh";
}

sub login
{ # login and download rep and xp xml files
my$state = shift;
my$ua = LWP::UserAgent->new; # create a web browser object (useragent)
$ua->agent("reputer/$info{'version'}"); # call it reputer
$ua->cookie_jar(HTTP::Cookies->new()); # enable cookies
$ua->proxy(http=>"$proxy") if ($use_proxy eq 'yes'); # proxy

# build a request object, returns cookies
my$req = POST ($pmurl, [op=>'login',user=>$username,passwd=>$password,
+expires=>'+10y',node_id=>'16046']);
if($use_proxy eq 'yes'){$req->proxy_authorization_basic("$proxyid", "$
+proxypass")} # proxy
my$res = $ua->request($req); # make request

$req = GET ($repurl); # build new request (user rep data)
if($use_proxy eq 'yes'){$req->proxy_authorization_basic("$proxyid", "$
+proxypass")} # proxy
$res = $ua->request($req); # make request
$repxml = $res->content; # extract content of response
unless($repxml=~/\S/){
    if($state eq 'detect'){ # restore if download fails
        &restore();
        select($handle);
        &begin_html($metac);
        print qq~Download failed. Previous view restored, 
        <a href="$uri?n=changes">reloading...</a>~;
        exit
        }
    else{
        unless($begin_html == 1){&begin_html()}
        print qq~$bq Rep download failed, 
        try again or <a href="$uri?n=login">login</a>.~;
        exit
        }
    }
$req = GET ($xpurl); # make new request (user rep data)
if($use_proxy eq 'yes'){$req->proxy_authorization_basic("$proxyid", "$
+proxypass")} # proxy
$res = $ua->request($req);
$xpxml = $res->content;
unless($xpxml=~/\S/){
    unless($begin_html == 1){&begin_html()}
    print qq~$bq XP download failed, 
    try again or <a href="$uri?n=login">login</a>.~;
    exit
    }
return
}

sub detect_changed_nodes
{ 
&copy($repthen,"$repthen.bak");
&copy($repnow,"$repnow.bak");

open(OLD,"< $repnow") or die "$!";
open(TMP,"> $repthen") or die "$!";
select(TMP);
while(<OLD>){ # repnow -> (fix variables) -> repthen
    $_=~s/\$nowxp1 = \{/\$thenxp1 = \{/o;
    $_=~s/\$now1 = \{/\$then1 = \{/o;
    $_=~s/\$nowt = '/\$thent = '/o;
    print TMP $_;
    }
close(OLD) or die "$!";
close(TMP) or die "$!";
select($handle);

&getsave($repnow,'nowxp','now','nowt','detect');
&getsave($df,'xpdat','dat','makedat'); # also update node list data fi
+le
&begin_html($metac);
print qq~Download complete, <a href="$uri?n=changes">analyzing...</a>~
+;
}

sub program_list
{ # list external programs
if(($public_access ne 'yes') && (defined %programs)){
    print qq~<table border="0" cellpadding="2" cellspacing="1" bgcolor
+="#bbbbbb" width="100%">
    <tr>~;
    for(sort {$b cmp $a} keys %programs){
        my$g = $_;
        $g =~ tr/ /+/;
        print qq~<td align="center"><a href="$uri?exec=$g">$_</a></td>
+~;
        }
    print qq~</tr></table>~;
    }
}

sub install_xml_simple
{
print header; print qq~Install 
<a href='http://search.cpan.org/search?dist=XML-Simple'>XML::Simple</a
+>~; 
}

sub fixxml
{ # replace ascii chrs that are not legal xml with underscore
# nodes with title like this would break links back to the node
$xml = shift;
$xml =~ s/[\r\n\t]//g; # jcwren
$xml =~ tr/\x80-\xff/_/; #
$xml =~ tr/\x00-\x1f/_/; #
return $xml;
}

sub getsave
{ # save data files according to passed parameters
my$state = $_[4];
unless(($i{'n'} eq 'make data') || ($nodat == 1)){
    &login($state); # returns $repxml and $xpxml
    &fixxml($xpxml); # returns $xml
    $xpdata = XMLin($xml, keyattr => 'XP', forcearray => 1);

    &fixxml($repxml); # returns $xml
    $data = XMLin($xml, keyattr => 'NODE', forcearray => 1);
    }
open(DAT,"> $_[0]") or die "$!";

$Data::Dumper::Indent = $ddi;
$Data::Dumper::Varname = "$_[1]"; 
print DAT Dumper($xpdata);

$Data::Dumper::Indent = $ddi;
$Data::Dumper::Varname = "$_[2]"; 
print DAT Dumper($data);
print DAT '$'.$_[3]." = '$today';";

close(DAT) or die "$!";
}

sub filedata
{ # find and print file size and createtime
my$size = (-s $_[0]);
my$when = (stat($_[0]))[9];
$when = sprintf "%s", scalar localtime($when);
print '<tt> - '.$size.' bytes, created '.$when.'</tt><br>';
}

sub copy
{ # simple file copy 
if(-e $_[0]){ 
    open(OLD,"< $_[0]") or die "$!";
    } 
else{
    &begin_html($metad); print "$_[0] doesn't exist";
    exit
    }
open(NEW,"> $_[1]") or die "$!";
select(NEW);
while(<OLD>){ print NEW $_ }
close(OLD) or die "$!";
close(NEW) or die "$!";
select($handle);
}

sub erase
{ # erase passed files and print results
&begin_html($metad,'<ol>');
for(@_){ 
    if(-e $_){ 
        unlink $_; 
        print "<li>$_ deleted";
        } else { print "<li>$_ doesn't exist"; }
    }
print "</ol><p><a href='$uri?n=config'>Reloading...</a>";
}

sub restore
{ # restore previous view
&copy("$repthen.bak",$repthen);
&copy("$repnow.bak",$repnow);
if($i{'n'}=~/restore/){ 
    select($handle);
    &begin_html($metac);
    print qq~Previous restored, <a href="$uri?n=changes">reloading...<
+/a>~;
    exit
    }
}

sub safety
{ # make or restore from safe backup
my$state = shift;
if($state eq 'backup'){
    &copy($repthen,"$repthen.safe");
    &copy($repnow,"$repnow.safe");
    &begin_html($metac);
    print qq~Saved to the safe backup, <a href="$uri?n=changes">reload
+ing...</a>~;
    }
if($state eq 'restore'){
    &copy("$repthen.safe",$repthen);
    &copy("$repnow.safe",$repnow);
    &begin_html($metac);
    print qq~Safe backup restored, <a href="$uri?n=changes">reloading.
+..</a>~;
    }
}

sub makedat
{ # make the main data file
&getsave($df,'xpdat','dat','makedat');
unless($i{'re'}==1){
    print qq~<p> $bq
    <b>Data file $df created.</b><p>
    Further access will use this data file until it's 
    <a href="$uri?n=make+data">refreshed</a> or overwritten.~;
    }
if($i{'re'}==1){ print "Location: $uri?n=$i{'mode'}\n\n"}
}

sub import
{ # function
open(DAT,"< $i{'filename'}") or die "$!";
local $/ = undef;
my$imports = <DAT>;
close(DAT) or die "$!";

&begin_html();
unless($imports=~/^M/){ 
    print qq~<p>$bq Invalid data in $i{'filename'}.<br>
    Must be uuencoded data...~;
    exit
    }
$imports = unpack ("u", $imports); # uudecode
$imports = uncompress($imports); # uncompress

unless(defined($imports)){ 
    print qq~<p>$bq Invalid data in $i{'filename'}.<br>
    Must be zlib compressed data...~;
    exit
    }
open(DAT,"> $df") or die "$!";
print DAT $imports;
close(DAT) or die "$!";

print qq~<p> $bq
<b>$i{'filename'}</b> imported and saved as <b>$df</b><p>
Sorted node list will read from this file until it's overwritten by 
'refresh', 'detect change' or 'import'.
<form method="$form_method"> Return to 
<input type="submit" name="n" value="config"></form> $eh~;
}

sub import_data
{ # menu
my@dir;
opendir THIS, "$temp" or die "$!";
while(defined ($_ = readdir(THIS))){
    next unless $_ =~ m|reputer-(.*?)\.export|;
    push @dir, $_;
    }
closedir THIS or die "$!";
@dir = sort { lc($a) cmp lc($b) } @dir;
&begin_html();
print qq~<table border="1" cellpadding="6" cellspacing="0">
<tr><th align="left" colspan="2"><h2>Import</h2></td></tr>
<tr><form method="$form_method"><td>
Showing files named<p>
<b>reputer-username.export</b>
<p>
in the temp dir ($temp). 
<p>Importing a file overwrites the<br>
current data file ($df), and allows <br>
viewing and sorting the imported nodes.<br></td><td>
<select name="filename" size="10">~;
    for(@dir){
        print "<option value='$_'>$_";
        }
print qq~</select><br>
<input type="submit" name="n" value="import data">
<input type="submit" name="n" value="config"></td></form></tr></table>
+ $eh~;
exit
}

sub export_data
{
my($size1,$size2);
open(DAT,"< $df") or die "$!";
local $/ = undef;
my$exports = <DAT>;
close(DAT) or die "$!";

$size1 = (-s($df));
$exports = compress($exports); # compress
unless(defined($exports)){ 
    print qq~<p>$bq    zlib compression failed...~;
    exit
    }
$exports = pack ("u", $exports); # uuencode

$xusername =~ tr/ /+/;
if($xusername=~/^([-\@\w.]+)$/){$xusername=$1} # untaint filename
else{ die "Error! Can't use $xusername as part of the filename."}

my$ef = $temp."reputer-$xusername.export";

unless($i{'e'} eq 'screen'){
    open(DAT,"> $ef") or die "$!";
    print DAT $exports;
    close(DAT) or die "$!";
    $size2 = (-s($ef));
    }

if($i{'e'} eq 'screen'){
    $size2 = length($exports);
    }
my$fu = sprintf("%d",(($size2/$size1)*100));

$exports = encode_entities($exports);
my$lines = $exports =~ tr/\n/\n/;
$lines = ($lines/2); # testarea rows
&begin_html();
print '<div align="right"';
&print_nav('z');
print qq~</div>\n
<!-- CUT AND PASTE FROM THE TEXTAREA, NOT THE HTML SOURCE -->\n
<p><form>Data exported~;

unless($i{'e'} eq 'screen'){
    print qq~ to <a href="$ef"><tt>$ef</tt></a>~;
    }
print qq~<br>
original $size1 bytes, exported $size2 bytes ($fu%)<br>
<textarea cols='70' rows='$lines'>$exports<\/textarea></form>~;
}

sub dump_hash
{ # display raw data structure
print header('text/plain');
$Data::Dumper::Varname = "xpdat"; 
print Dumper($xpdata);
$Data::Dumper::Varname = "dat"; 
print Dumper($data);
}

sub begin_html
{ # print document html headers
my($metatag,$content) = @_;
unless(($metatag) && ($metatag eq 'fu')){
    if( ($i{'show'}) || ($i{'ft'}) || ($i{'sr'}) ){
        my($sc,$ft,$sr);
        if($i{'show'}){
            $sc = CGI::Cookie->new(-name=>'show',-value=>"$i{'show'}",
+-expires=>'+10y');
            }
        if( ($i{'ft'}) && ($i{'ft'} eq 'yes') ){
            $fix_title = 'yes';
            $ft = CGI::Cookie->new(-name=>'ft',-value=>'yes',-expires=
+>'+10y');
            }
        else{$ft = CGI::Cookie->new(-name=>'ft',-value=>'no',-expires=
+>'now'); $fix_title = 'no'}
        
        if( ($i{'sr'}) && ($i{'sr'} eq 'yes') ){
            $strip_re = 'yes';
            $sr = CGI::Cookie->new(-name=>'sr',-value=>'yes',-expires=
+>'+10y');
            }
        else{$sr = CGI::Cookie->new(-name=>'sr',-value=>'no',-expires=
+>'now'); $strip_re = 'no'}
        
        print header(-cookie=>[$sc,$ft,$sr]);        
        }
    else{ print header }
    }
if($metatag eq 'fu'){ undef($metatag)}
print qq~<html><head><title>reputer</title> $metatag 
<style><!-- td{ font-family:arial;font-size:80%; }// --></style></head
+>
$bodytag $content~;
$begin_html = 1;
}

sub the_bridge
{ # print the summary/menu
print qq~<table border="0" cellpadding="2" cellspacing="0" bgcolor="#d
+0d0d0" width="100%">
<tr><td valign="top">~;
&summary(@_);
print '</td><td valign="middle" align="right">';
&print_form();
print '</td></tr></table>';
&program_list(); # list external programs
}

sub gif
{ # a gif for the graph
local $| = 0;
print "Content-type: image/gif\n\n", pack "H*", 
"47494638396101000100800000ffffff". 
"00000021f90401000000002c00000000". 
"010001000002024401003b";
}

sub print_form
{ # sort form
my$bit = shift;
my($ftc,$src) = '';
print qq~<FORM method="$form_method">
<SELECT NAME="n" size="1">
<OPTION $cd VALUE="cd">$modescs{'cd'}
<OPTION $ca VALUE="ca">$modescs{'ca'}
<OPTION $rd VALUE="rd">$modescs{'rd'}
<OPTION $ra VALUE="ra">$modescs{'ra'}
<OPTION $ta VALUE="ta">$modescs{'ta'}
<OPTION $td VALUE="td">$modescs{'td'}</SELECT>~;
if($show eq ''){$show = 0}
if($start eq ''){$start = 1}
print qq~<input type="hidden" name="show" value="$show">
<input type="hidden" name="start" value="$start">
<INPUT TYPE="submit" VALUE="Sort"><br>~;
if($fix_title eq 'yes'){$ftc = ' checked'}
if($strip_re eq 'yes'){$src = ' checked'}
print qq~<b>strip:</b> <input type="checkbox" name="ft" value="yes"$ft
+c> 
username <input type="checkbox" name="sr" value="yes"$src> re</FORM>~;
&print_nav($bit);
}

sub print_nav
{ # navigation buttons
my$bit = shift;
print "<FORM method='$form_method'>";
print '<INPUT TYPE="submit" name="n" VALUE=" ? "> ';
unless($public_access eq 'yes'){
    print '<INPUT TYPE="submit" name="n" VALUE="config"> '
    } 
print '<INPUT TYPE="submit" name="n" VALUE="changes"> '.
'<INPUT TYPE="submit" name="n" VALUE="graph"></FORM>';
unless($bit){ if($nodat!=1){ print qq~<b>Today:</b> $today<br>$md~}}
}

sub listitle
{
print qq~<p>
<table border="$bb" cellpadding="2" cellspacing="1" bgcolor="#d0d0d0" 
+width="100%">
<tr><th colspan="3" align="left"><h2>Nodes sorted by $modesc</h2></th>
<td align="right" valign="top"><form method="$form_method">
<input type="hidden" name="n" value="make data">
<input type="hidden" name="mode" value="$mode">
<input type="hidden" name="re" value="1">~;
unless($public_access eq 'yes'){
    print '<input type="submit" value="Refresh">'
    }
print '&nbsp;</form></td></tr>';
}

sub help
{
&begin_html(undef,'<div align="right">');
&print_form('z');
my$self = -s $0;
if($show eq ''){$show = 0}
if($start eq ''){$start = 1}
print qq~</div> $bq <h1>reputer $info{'version'}</h1> 
Because of it's size ($self bytes) reputer has two nodes on <a href="$
+pmurl">Perlmonks</a>.
<ul><li><a href="$pmurl?node=reputer">The source code is here</a> in t
+he code catacombs.
<li>Please make replies to <a href="$pmurl?node=reputer+reply">this cr
+osslinked reply node</a>.</ul>
<p><FORM method="$form_method">
<h2>Sort</h2>
<SELECT NAME="n" size="1">
<OPTION $cd VALUE="cd">$modescs{'cd'}
<OPTION $ca VALUE="ca">$modescs{'ca'}
<OPTION $rd VALUE="rd">$modescs{'rd'}
<OPTION $ra VALUE="ra">$modescs{'ra'}
<OPTION $ta VALUE="ta">$modescs{'ta'}
<OPTION $td VALUE="td">$modescs{'td'}</SELECT> 
<input type="hidden" name="show" value="$show">
<input type="hidden" name="start" value="$start">
<INPUT TYPE="submit" VALUE="Sort"><br>~;
my($ftc,$src) = '';
if($fix_title eq 'yes'){$ftc = ' checked'}
if($strip_re eq 'yes'){$src = ' checked'}
print qq~<font size="-1"><b>strip:</b> <input type="checkbox" name="ft
+" value="yes"$ftc> 
username <input type="checkbox" name="sr" value="yes"$src> re</font><p
+>
<b>The default screen. Sort nodes by date, reputation or title.</b>
<ul>
<li>Option to strip <i>($username)</i> and <i>Re:</i> from node titles
+.~;
if($public_access ne 'yes'){
    print qq~<li>Refresh button updates the node list with fresh data 
+from perlmonks.~}
print qq~</ul></FORM><FORM method="$form_method">
<h2>Graph</h2>
<INPUT TYPE="submit" name="n" VALUE="graph"><p>
<b>Graph number of nodes by reputation.</b>
<ul>
<li>Avg reputation is highlighted only if there is at least one node a
+t that rep. 
</ul>
<h2>Changes</h2>
<INPUT TYPE="submit" name="n" VALUE="changes"><p>~;
if($public_access ne 'yes'){        
    print qq~<b>Detect new, changed and deleted nodes.</b><br>
    <ul>
    <li>Display detailed statistics. Undo and backup.
    <li>Selecting 'detect change' twice wipes out 'restore previous'.
    </ul>~;
    }
if($public_access eq 'yes'){        
    print qq~Display new, changed and deleted nodes with<br>
    detailed statistics.~;
    }
print qq~<br></FORM>~;

unless($public_access eq 'yes'){
    print qq~<FORM method="$form_method"><h2>Config</h2>
    <INPUT TYPE="submit" name="n" VALUE="config"><p>
    <b>Manage cookies and files, check for updates.</b></FORM>~;
    }
print qq~<p align="right">coded by <a href="$pmurl?node=epoptai">epopt
+ai</a>~;
}

sub config
{ # configuration menu
my%exists;
my@files = (
    "$df","$repnow","$repthen","$repnow.bak","$repthen.bak",
    "$repnow.safe", "$repthen.safe","reputer-$xusername.export");
for(@files){ if(-e $_){$exists{$_}=1} else {$exists{$_}=0}}
$info{'date'}=~s/(....)(..)(..)/$1-$2-$3/o;
print qq~<table width="100%" border="0" bgcolor="#ffffff" cellpadding=
+"4" cellspacing="0">
<tr><th align="left"><h1>Configure</h1></th></tr></table> $bq~;
&login_form('config');
print qq~<hr><form method="$form_method"><h1>Files</h1>
<i>reputer creates up to 8 data files</i>
<h3>A file used for the sortable node list:</h3>
<b>reputer.dat</b>~;

if($exists{$df}==1){&filedata($df)} else{ print " - doesn't exist<br>"
+}
print qq~<li>
<input type="hidden" name="n" value="make data"> 
<input type="submit" value="refresh">
- refresh node, reputation and xp data file</FORM>~;
if($exists{$df}==1){ 
    print qq~<form method="$form_method">
    <input type="hidden" name="n" value="dumphash"> 
    <li><input type="submit" value="dump"> - dump the raw data structu
+re to screen</form>~}
if($trade!=1){ 
    print qq~Install <a href='http://search.cpan.org/search?dist=Compr
+ess-Zlib'>
    Compress::Zlib</a> to enable import and export functions.~}
if($trade==1){
    my$size;
    $xusername =~ tr/ /+/;
    if(-e $files[7]){$size = (-s $files[7])}
    else{$size = ((-s $files[0])/3)}    
    $size = sprintf("%d", $size);
    if($exists{$df}==1){
        print qq~<form method="$form_method">
        <b>Export/import a compressed data file containing node, reput
+ation and xp data.</b><p>
        <li><INPUT TYPE="submit" name="n" VALUE="export"> - 
        export $df as <i>$files[7]</i> ($size bytes).<br>
        <INPUT TYPE="checkbox" name="e" VALUE="screen"> <font size="-1
+">don't save, display only</font><p>
        <li><INPUT TYPE="submit" name="n" VALUE="import"> - 
        select a file to import, overwrites $df</FORM>~;
        }
    }
print qq~<hr>
<FORM method="$form_method"><input type="hidden" name="erase" value="c
+urrent">
<h3>A pair of lists for <i>'changes':</i></h3>
<b>reputer.now</b>~;

if($exists{$repnow}==1){&filedata($repnow)} else{ print " - doesn't ex
+ist<br>"}
print '<b>reputer.then</b>';

if($exists{$repthen}==1){&filedata($repthen)} else{ print " - doesn't 
+exist<br>"}
if(($exists{$repnow}==1) && ($exists{$repthen}==1)){ 
    print '<INPUT TYPE="submit" VALUE="delete">'
    }
print qq~</FORM><hr><FORM method="$form_method">
<input type="hidden" name="erase" value="backup">
<h3>A pair of lists for <i>'previous view':</i></h3>
<b>reputer.now.bak</b>~;

if($exists{"$repnow.bak"}==1){&filedata("$repnow.bak")} else{ print " 
+- doesn't exist<br>"}
print '<b>reputer.then.bak</b>';

if($exists{"$repthen.bak"}==1){&filedata("$repthen.bak")} else{ print 
+" - doesn't exist<br>"}
if(($exists{"$repnow.bak"}==1) && ($exists{"$repthen.bak"}==1)){ 
    print '<INPUT TYPE="submit" name="n" VALUE="delete">'
    }
print '</form>';

if(($exists{"$repnow.bak"}==1) && ($exists{"$repthen.bak"}==1)){ 
    print qq~<FORM method="$form_method"><INPUT TYPE="submit" name="n"
+ VALUE="restore previous"> - 
    replace the <i>changes</i> pair with these files.<hr></FORM>~} 
else{ print '<hr>'}

print qq~<FORM method="$form_method"><input type="hidden" name="erase"
+ value="safe">
<h3>A pair of lists for <i>'safe backup':</i></h3><b>reputer.now.safe<
+/b>~;

if($exists{"$repnow.safe"}==1){&filedata("$repnow.safe")} else{ print 
+" - doesn't exist<br>"}
print '<b>reputer.then.safe</b>';

if($exists{"$repthen.safe"}==1){&filedata("$repthen.safe")} else{ prin
+t " - doesn't exist<br>"}
if(($exists{"$repnow.safe"}==1) && ($exists{"$repthen.safe"}==1)){ 
    print '<INPUT TYPE="submit" name="n" VALUE="delete">'
    }
print '</form>';

if(($exists{"$repnow.safe"}==1) && ($exists{"$repthen.safe"}==1)){ 
    print qq~<FORM method="$form_method"><INPUT TYPE="submit" name="n"
+ VALUE="safe restore"> - 
    replace the <i>changes</i> pair with these files.<hr></FORM>~} 
else{ print '<hr>'}
print qq~<form method="$form_method"><h1>Updates</h1>
This is version $info{'version'} ($info{'date'}). 
Check for an <input type="submit" name="n" value="update"></form>~;
print $eh;
}

sub check_update
{ # looks for <!--INFO:version=n,date=yyyymmdd--> on code node
# and compares it with version data from the %info hash
my$check_rev;
my$check = get 'http://www.perlmonks.org/index.pl?node_id=69581';
if($check !~ /\S/){
    &begin_html(); 
    print qq~$bq Download failed, <a href="$uri?n=update">try again?</
+a>~; 
    &print_nav('z');
    exit
    }
unless($check =~ /<!--INFO:/){
    &begin_html(); 
    print qq~$bq Version information not detected, try again later or 
+go 
    to the <a href="$pmurl?node=reputer">reputer homenode</a>.~; 
    &print_nav('z');
    exit
    }
my@check = split /\n/, $check;

@check = grep /<!--INFO:.*?-->/, @check;
$check = $check[0];
$check =~ s/<!--INFO://o;
$check =~ s/-->//o;
@check = split /,/, $check;
my$cnt = (@check+1);

for(@check){
    my($k,$v) = split /=/, $_;
    if($k eq 'version'){$check_rev = $v}
    }
&begin_html();
print qq~<table border="1" cellpadding="6" cellspacing="1">
<tr bgcolor="#ffffff"><th colspan="$cnt"><h1>~;
if($check_rev > $info{'version'}){ print qq~Update Available~}
if($check_rev == $info{'version'}){    print qq~This is the current ve
+rsion~}
if($check_rev < $info{'version'}){ print qq~This version newer than up
+date!~}
print '</h1></td></tr><tr bgcolor="#cccccc"><th>&nbsp;</th>';

for(@check){
    my($k,$v) = split /=/, $_;
    print qq~<th>$k</th>~
    }
if($check_rev < $info{'version'}){
    print qq~</tr><tr><th align="right"><a href="$pmurl?node=reputer">
+Downgrade</a> </th>~
    }
else{ 
    print qq~</tr><tr><th align="right"><a href="$pmurl?node=reputer">
+Update</a> </th>~
    }
for(@check){ # update
    my($k,$v) = split /=/, $_;
    if($k=~/date/){$v=~s/(....)(..)(..)/$1-$2-$3/o}
    print qq~<td align="center">$v</td>~
    }
print '</tr><tr><th align="right">This </th>';

for(@check){ # this
    my($k,$v) = split /=/, $_;
    if($k=~/date/){$info{$k}=~s/(....)(..)(..)/$1-$2-$3/o}
    print qq~<td align="center">$info{$k}</td>~
    }
print '</tr></table>';
&print_nav('z');
}

sub nowthen
{ # calculate changed nodes
if(($then_is != 1) or ($now_is != 1)){
    &getsave($repthen,'thenxp','then','thent');
    &getsave($repnow,'nowxp','now','nowt');
    print qq~<p>$bq Files created, try again later by selecting 'detec
+t change'.<p>
    Select <a href="$uri?n=changes">changes</a> again to see a summary
+.~;
    exit
    }
my(%repgain,%reploss,%repthen,%repnow,%thenall,%nowall);
my(%now_content,%now_created,%now_rep,%then_content,%then_created,%the
+n_rep);
my$many = 0; # changed nodes

# extract xp info
my($now_xp2nxt,$now_level,$now_xp);
    for my $xpnow(@{$nowxp->{'XP'}}){ # now
        $now_xp2nxt = $xpnow->{'xp2nextlevel'};
        $now_level = $xpnow->{'level'};
        $now_xp = $xpnow->{'xp'};
        }
my($then_xp2nxt,$then_level,$then_xp);
    for my $xpthen(@{$thenxp->{'XP'}}){ # then
        $then_xp2nxt = $xpthen->{'xp2nextlevel'};
        $then_level = $xpthen->{'level'};
        $then_xp = $xpthen->{'xp'};
        }

my($now_arts,$now_trep,$then_arts,$then_trep) = 0;

for my $then (@{$then->{'NODE'}}){
    $then_trep += $then->{'reputation'}; # total rep then
    $then_arts++;
    }
# unravel the data into a bunch of hashes keyed on node_id
for my $now (@{$now->{'NODE'}}){ # now
    $now_content{$now->{'id'}} = $now->{'content'};
    $now_created{$now->{'id'}} = $now->{'createtime'};
    $now_rep{$now->{'id'}} = $now->{'reputation'};
    $now_trep += $now->{'reputation'}; # total rep now
    $now_arts++;
    for my $then (@{$then->{'NODE'}}){ # then
        $then_content{$then->{'id'}} = $then->{'content'};
        $then_created{$then->{'id'}} = $then->{'createtime'};
        $then_rep{$then->{'id'}} = $then->{'reputation'};
        if($now->{'id'} == $then->{'id'}){
            if($now->{'reputation'} > $then->{'reputation'}){ # gain
                $repgain{$now->{'id'}} = ($now->{'reputation'} - $then
+->{'reputation'});
                $repthen{$now->{'id'}} = $then->{'reputation'};
                $repnow{$now->{'id'}}  = $now->{'reputation'};
                $many++;
                }
            if($now->{'reputation'} < $then->{'reputation'}){ # loss
                $reploss{$now->{'id'}} = ($then->{'reputation'} - $now
+->{'reputation'});
                $repthen{$now->{'id'}} = $then->{'reputation'};
                $repnow{$now->{'id'}}  = $now->{'reputation'};
                $many++;
                }
            }
        $thenall{$then->{'id'}} = $then->{'reputation'};
        }
    $nowall{$now->{'id'}} = $now->{'reputation'};
    }

my(@newnodes,@delnodes,@thenreps,@nowreps) = ();
for(sort {$b <=> $a} keys %nowall){ # new nodes
    push (@nowreps, $nowall{$_});
    push (@newnodes, $_) unless exists $thenall{$_};
    }
for(sort {$b <=> $a} keys %thenall){ # deleted nodes
    push (@thenreps, $thenall{$_});
    push (@delnodes, $_) unless exists $nowall{$_};
    }
# calculate the results of the rep/xp comparison till next print
@nowreps = sort {$b <=> $a} @nowreps;
@thenreps = sort {$b <=> $a} @thenreps;
$now_arts = (scalar(@nowreps)-1); # subtract homenode from total
$then_arts = (scalar(@thenreps)-1);

my$change_arts = ($now_arts-$then_arts);
my$change_reps = ($now_trep-$then_trep);
my$change_xp   = ($now_xp-$then_xp);
my$nn = 0;

if(($many == 0) && ($change_arts != 0)){$many = $change_arts; $nn = 1}
+ 

my$thenavg  = sprintf ("%3.2f", $then_trep / $then_arts);
my$nowavg  = sprintf ("%3.2f", $now_trep / $now_arts);
my$change_avg = sprintf ("%3.2f", ($nowavg-$thenavg));
my$change_max = ($nowreps[0]-$thenreps[0]);
my$change_min = ($nowreps[-1]-$thenreps[-1]);

if($change_arts > 0){$change_arts = '+'.$change_arts}
if($change_reps > 0){$change_reps = '+'.$change_reps}
if($change_xp > 0){$change_xp = '+'.$change_xp}
if($change_avg > 0){$change_avg = '+'.$change_avg}
if($change_max > 0){$change_max = '+'.$change_max}
if($change_min > 0){$change_min = '+'.$change_min}

my$sz = 1; # size of select menu
my($e1,$e2,$e3);
if( (-e $repthen) && (-e $repnow) ){ $sz++; $e1=1 } # if file exists i
+ncrease select menu size & list item
if( (-e "$repthen.bak") && (-e "$repnow.bak") ){ $sz++; $e2=1 }
if( (-e "$repthen.safe") && (-e "$repnow.safe") ){ $sz++; $e3=1 }

print qq~<table border="0" cellpadding="2" cellspacing="0" bgcolor="#b
+0b0b0" width="100%">
<tr><form method="$form_method"><td valign="middle">~;
unless($public_access eq 'yes'){
    print qq~<select name="n" size="$sz">
    <option value="detect change"> detect change~;
    if($e2 == 1){ print '<option value="restore previous"> restore pre
+vious'}
    if($e1 == 1){ print '<option value="safe backup"> safe backup'}
    if($e3 == 1){ print '<option value="safe restore"> safe restore'}
    print '</select><input type="submit" value="Go">';
    }
print qq~&nbsp;</td></form><th><h1>changes</h1></th><td align="right">
+<b>
Then:</b> $thentime<br><b>Now:</b> $nowtime<br></td></tr></table><p>
<table border="$bb" cellpadding="2" cellspacing="1" bgcolor="#b0b0b0" 
+width="100%">
<tr align="right" bgcolor="#ffffff"><td>&nbsp;</td><td>then</td><td>no
+w</td><td>change</td></tr>~;

&change_sum($change_arts,'Total nodes',$then_arts,$now_arts,$change_ar
+ts);
&change_sum($change_reps,'Total reputation',$then_trep,$now_trep,$chan
+ge_reps);
&change_sum($change_xp,'Total experience',$then_xp,$now_xp,$change_xp)
+;
&change_sum($change_max,'Max reputation',$thenreps[0],$nowreps[0],$cha
+nge_max);
&change_sum($change_avg,'Avg reputation',$thenavg,$nowavg,$change_avg)
+;
&change_sum($change_min,'Min reputation',$thenreps[-1],$nowreps[-1],$c
+hange_min);

print qq~</table><p>
<table border="$bb" cellpadding="2" cellspacing="1" bgcolor="#b0b0b0" 
+width="100%">~;

my(@trc,$trc); # total rep from changed nodes
if(($many == 0) && ($nn == 0)){ # no changed nodes
my($rp,$sr) = '';
    if((-e "$repthen.bak") && (-e "$repnow.bak")){
        $rp = '<input type="submit" name="n" value="restore previous">
+';
        }
    if((-e "$repthen.safe") && (-e "$repnow.safe")){
        $sr = '<input type="submit" name="n" value="safe restore">';
        }
    print qq~<p>$bq No changed nodes. Try again later. 
    <p><form method="$form_method">
    $rp $sr </form>~;
    exit
    }
if(($many > 0) && ($nn == 0)){ # changed nodes
    print qq~<tr><td colspan="6"><b>Changed</b></td></tr>
    <tr><td>node</td><td>title</td><td>created</td><td>then</td><td>no
+w</td><td>change</td></tr>~;
    }
for my $foo (sort {$b <=> $a} keys %nowall){ # sort by node id
    for my $gain (sort {$b <=> $a} keys %repgain){ # gain
        if($gain == $foo){
            print qq~<tr bgcolor="#ffffff" align="center"><td>$gain </
+td>
            <td align="left"> <a href="$pmurl?node_id=$gain">$now_cont
+ent{$gain}</a> </td>
            <td> <small>$now_created{$gain}</small> </td>
            <td> $repthen{$gain} </td>
            <td> $repnow{$gain} </td>
            <td> +$repgain{$gain}</td></tr>~;
            push @trc, $repgain{$gain}
            }
        }
    for my $loss (sort {$b <=> $a} keys %reploss){ # loss
        if($loss == $foo){
            print qq~<tr bgcolor="#ffbbbb" align="center"><td>$loss </
+td>
            <td align="left"> <a href="$pmurl?node_id=$loss">$now_cont
+ent{$loss}</a> </td>
            <td> <small>$now_created{$loss}</small> </td>
            <td> $repthen{$loss} </td>
            <td> $repnow{$loss} </td>
            <td> -$reploss{$loss}</td></tr>~;
            push @trc, '-'.$reploss{$loss}
            }
        }
    }

if(@newnodes){ # new nodes
    print qq~<tr><td colspan="6"><b>New</b></td></tr>
    <tr><td>node</td><td>title</td><td>created</td>
    <td>then</td><td>now</td><td>change</td></tr>~;
    for my $foo (sort {$b <=> $a} keys %nowall){
        for(@newnodes){
            my$color = '#ffffff';
            my$pref = '+';
            if($_ == $foo){
                if($now_rep{$_} == 0){ $pref = ''}
                if($now_rep{$_} > 0){ $pref = '+'}
                if($now_rep{$_} < 0){ $color = '#ffbbbb'; $pref = ''}
                print qq~<tr bgcolor="$color" align="center"><td>$_ </
+td>
                <td align="left"> <a href="$pmurl?node_id=$_">$now_con
+tent{$_}</a> </td>
                <td> <small>$now_created{$_}</small> </td>
                <td> 0 </td>
                <td> $now_rep{$_} </td>
                <td> $pref$now_rep{$_}</td></tr>~;
                push @trc, $now_rep{$_}
                }
            }
        }
    }
if(@delnodes){ # deleted nodes
    print qq~<tr><td colspan="6"><b>Deleted</b></td></tr>
    <tr><td>node</td><td>title</td><td>created</td>
    <td>then</td><td>now</td><td>change</td></tr>~;
    for my $foo (sort {$b <=> $a} keys %thenall){
        for(@delnodes){
            my$color = '#ffffff';
            if($_ == $foo){
                print qq~<tr bgcolor="$color" align="center"><td>$_ </
+td>
                <td align="left"> <a href="$pmurl?node_id=$_">$then_co
+ntent{$_}</a> </td>
                <td> <small>$then_created{$_}</small> </td>
                <td> $then_rep{$_} </td>
                <td> &nbsp; </td>
                <td> &nbsp;</td></tr>~;
                }
            }
        }
    }
for(@trc){$trc += $_} # total rep from changed nodes
$trc[0] = '#bbbbbb';
if($trc > 0){$trc = '+'.$trc}
if($trc < 0){$trc[0] = '#ffbbbb'}
print qq~<tr align="center" valign="bottom" bgcolor="$trc[0]">
<td colspan="5" align="right"><p><br>Total experience from node change
+s</td>
<td>$trc</td></tr></table> $eh~;
} # end sub nowthen

sub summary
{ # totals and averages section of the main menu
my$total_rep = shift; # had to shift to get them all
my$xp = shift;
my$rephi = shift;
my$replo = shift;
my$usersince = shift;

my@level = qw(anonymous initiate novice acolyte scribe monk friar abbo
+t bishop pontiff saint);
my@lastnode = sort {$b cmp $a} values %node_cre;

print qq~<table border="0" width="100%" cellpadding="0" cellspacing="0
+">
<tr bgcolor="#ffffff"><td><b>User:</b> $xusername (<a href="$pmurl?nod
+e_id=$homenode">$homenode</a>)<br>
<b>Level:</b> $level - $level[$level] <br></td>
<td align='right'><b>User since:</b> $usersince <br>
<b>Last here:</b> $lastnode[0] <br></td></tr>
<tr><td colspan="2" height="5"><font size="-7">&nbsp;</font></td></tr>
<tr bgcolor="#f0f0f0"><td>
<table border="0" width="100%" cellpadding="2" cellspacing="0">
<tr align="right"><td>~;

my$avg  = sprintf ("%3.2f", ($total_rep/$total_nodes)); 
$avgrep = sprintf ("%d", $avg);  
$replo  = sprintf ("%d", $replo);

print qq~Total nodes: $total_nodes </td></tr><tr align=right><td>
Total reputation: $total_rep </td></tr><tr align=right><td>
Total experience: $xp </td></tr></table></td>
<td><table border="0" width="100%" cellpadding="2" cellspacing="0"><tr
+ align="right"><td>
Max reputation: $rephi </td></tr><tr align=right><td>
($avg) Avg reputation: $avgrep </td></tr><tr align=right><td>
Min reputation: $replo </td></tr></table></td></tr></table>~;
}

sub change_sum
{ # display the xp/rep change summary
my($v1,$v2,$v3,$v4,$v5) = @_;
my$color = '';
if($v1 < 0){$color = ' bgcolor="#ffbbbb"'}
if($v1 > 0){$color = ' bgcolor="#d0d0d0"'}
print qq~<tr align="right"><td bgcolor="#ffffff">
$v2</td><td bgcolor="#d0d0d0">
$v3</td><td bgcolor="#d0d0d0">
$v4</td><td$color>
$v5</td></tr>~;
}

sub graph
{ # calculate and display the graphs
my($hm1,$hm2,$hm3,$bdr);
if($i{'histmode'}=~/02/){ $bdr = 1 } else { $bdr = 0 }
print qq~<p><table border="$bdr" cellpadding="0" cellspacing="0" width
+="100%">
<tr><th align="left" colspan="3" valign="top">
<table border="0" cellpadding="0" cellspacing="0" width="100%" bgcolor
+="#cfcfcf">
<tr><th align="left">&nbsp;&nbsp;
<h2>Number of nodes by reputation
<font size="-1"><br>average rep and maximum num highlighted</font></h2
+></th>
<td><table align="right" border="0" cellpadding="3" cellspacing="0"><t
+r><td>~;

if( ($i{'histmode'}=~/01/) or (!$i{'histmode'}) ){ 
    $hm1 = ' checked';
    print qq~<b>mode one</b><br><small>
    bar height = fixed<br>
    bar width = number of nodes at that rep<br></small></td></tr>~
    }
if($i{'histmode'}=~/02/){ 
    $hm2 = ' checked';
    print qq~<b>mode two</b><br><small>
    bar height = rep<br>
    bar width = number of nodes at that rep<br></small></td></tr>~
    }
if($i{'histmode'}=~/03/){
    $hm3 = ' checked';
    print qq~<b>mode three</b><br><small>
    bar height = number of nodes at that rep<br>
    bar width = rep<br></small></td></tr>~
    }

print qq~<tr><form method="$form_method"><td align="right" valign="bot
+tom">
1<input type="radio" name="histmode" value="01"$hm1> 
2<input type="radio" name="histmode" value="02"$hm2> 
3<input type="radio" name="histmode" value="03"$hm3> 
<input type="hidden" name="n" value="graph">
<input type="submit" value="mode"></td></form></tr></table>
</td></tr></table></td></tr>~;

my@high = sort {$b <=> $a} values %rep_freq;
my@hig  = sort {$b <=> $a} keys %rep_freq;
my$mult = sprintf "%d", (600/$high[0]); # normalize bar width to scale
+ (highest num = 600 pixels)
my$mul  = sprintf "%d", (600/$hig[0]); # normalize bar width to scale 
+(highest num = 600 pixels)
print qq~<tr bgcolor="#b0b0b0"><td><b>$nb rep $nb</td><td><b>$nb num $
+nb</td><td>&nbsp;</td></tr>~;

my($ar,$fc,$arf,$fcf) = '';

for(sort {$b <=> $a} keys %rep_freq){ 
    my$w = ($rep_freq{$_}*$mult);
    my$h = 5;
    if($i{'histmode'}){
        if($i{'histmode'}=~/01/){}
        if($i{'histmode'}=~/02/){ $h = ($_); if($h == 0){$h = 1} }
        if($i{'histmode'}=~/03/){ $w = ($_*$mul); $h = $rep_freq{$_} }
        }
    if($_ == $avgrep){ # highlight avg rep
        $ar = 'bgcolor="#880066"'; 
        $fc = '<font color="white">'
        } 
    else{$ar=''; $fc='';}
    
    if($rep_freq{$_} == $high[0]){ # highlight frequency high
        $arf = 'bgcolor="#880066"'; 
        $fcf = '<font color="white">'
        }
    else{$arf=''; $fcf=''}

    print qq~<tr><td $ar align="right">$fc $_ $nb</td><td $arf align="
+right">$fcf $rep_freq{$_} $nb</td><td>~;
    print qq~<table border="0" cellpadding="0" cellspacing="0">
    <tr><td bgcolor="#880066"><img src="$uri?n=gif" width="$w" height=
+"$h" border="0"></td></tr></table>
    </td></tr>~
    }
print qq~<tr bgcolor="#b0b0b0">
<td><b>$nb rep $nb</td><td><b>$nb num $nb</td><td>&nbsp;</td></tr></ta
+ble><p>~;
}
Replies are listed 'Best First'.
reputer replies
by epoptai (Curate) on Apr 04, 2001 at 12:30 UTC
    This little node exists to host the invisible update info tag. Since the code is already large i'm hoping you will direct your comments to the reply node. (test)