#!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 = ' ';
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 < 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~"><< Prev $show</a></font> ~;
}
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~ <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 >></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
{
©($repthen,"$repthen.bak");
©($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
©("$repthen.bak",$repthen);
©("$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'){
©($repthen,"$repthen.safe");
©($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'){
©("$repthen.safe",$repthen);
©("$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 ' </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> </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~ </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> </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> </td>
<td> </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"> </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">
<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> </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> </td></tr></ta
+ble><p>~;
}
In reply to reputer
by epoptai
-
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.
