| 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.
Also includes proxy support, restricted public access mode,
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 = ' '; 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>~; } |
|
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
reputer replies
by epoptai (Curate) on Apr 04, 2001 at 12:30 UTC |
Back to
Code Catacombs