Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
#!perl -T # reputer analyzes and displays node reputation and xp data from perlm +onks.org # homenode = http://perlmonks.org/index.pl?node=reputer # # List user nodes sorted by rep, title or date in HTML tables. # Three ways to graph number of nodes by reputation. # Display changed, deleted and new node info and rep change. # Cookies save info used for lwp transfers, and display options. # Can write up to 8 data files in temp dir, so give it write permissio +n. # # Export/import enabled if Compress::Zlib is installed # Requires XML::Simple use strict; use CGI qw(header param url); eval("use XML::Simple 'XMLin'"); # required xml parser if($@){&install_xml_simple(); exit} use CGI::Cookie; use HTTP::Cookies; use HTTP::Request::Common; use HTML::Entities 'encode_entities'; use LWP::Simple 'get'; use LWP::UserAgent qw(agent cookie_jar request content); use Data::Dumper; #use CGI::Carp 'fatalsToBrowser'; # only use for debugging with -w my$trade = 0; eval("use Compress::Zlib"); unless($@){$trade = 1} # if installed enable export/import # config variables my$temp = './'; # where data files are saved my$public_access = ''; # 'yes' disables config, downloads, and externa +l program functions my$bodytag = '<body bgcolor="#aaaaaa" text="#000000">'; my$form_method = 'get'; # get or post, 'get' shows params in url my%programs = ( # full path to optional external programs, links will +appear in sort mode. # key = the display name, value = a system call which dumps output to +the browser. # 'xrepwalker' => 'perl xlukerep.pl', # 'xstatswhore' => 'perl xstatswhore.pl', # 'tracert perlmonks' => 'tracert perlmonks.org', # 'ping perlmonks' => 'ping perlmonks.org', ); # proxy my$use_proxy = ''; # 'yes' enables use thru the following proxy my$proxy = 'http://proxy.dom:port'; # must define this to use proxy my$proxyid = ''; my$proxypass = ''; # end config variables my$bb = 0; # table border on node list if($ENV{'HTTP_USER_AGENT'}){ # ie cant do cellspacing as border in nes +ted colored tables if(($ENV{'HTTP_USER_AGENT'}=~/MSIE/) || ($ENV{'HTTP_USER_AGENT'}!~/Moz +illa/)){ $bb = 1 }} my$perlmonks = ''; # default for links if no cookie set my$ddi = 0; # data dumper intent level, 0 = smallest files # paths and data files my$df = $temp.'reputer.dat'; # main data file my$repthen = $temp.'reputer.then'; # 'previous' rep file my$repnow = $temp.'reputer.now'; # 'present' rep file my$uri = url(); # html elements my$nb = '&nbsp;'; my$bq = '<blockquote>'; my$eh = '</body></html>'; my$metac = "<meta http-equiv='refresh' content='1;url=$uri?n=changes'> +"; my$metad = "<meta http-equiv='refresh' content='1;url=$uri?n=config'>" +; # general vars my$handle = select(); my$today = localtime(time); my%cookies = CGI::Cookie->fetch(); my%i = map{$_ => param($_)} param; my%info = ( version => '1.0', date => '20010404' ); my($fix_title,$strip_re) = ''; # sort mode descriptions my%modescs = ( ta => 'Title', td => 'Title Reverse', ra => 'Lowest Reputation First', rd => 'Highest Reputation First', ca => 'Oldest First', cd => 'Newest First' ); if(($i{'exec'}) && ($public_access ne 'yes')){ # external programs if(($ENV{PATH}) && ($ENV{PATH}=~/(.*)/s)){$ENV{PATH}=$1} # get tai +nt to accept our path if(exists $programs{$i{'exec'}}){ for(keys %programs){ if($_ eq $i{'exec'}){ my$status = system("$programs{$_}"); die "$programs{$_} failed: $?" unless $status == 0; } } } else{ print header; print "Can't find <i>$i{'exec'}</i> in program + list."} exit } if(($i{'erase'}) && ($public_access ne 'yes')){ # delete data files if($i{'erase'} eq 'current'){&erase($repnow,$repthen); exit} if($i{'erase'} eq 'backup'){&erase("$repnow.bak","$repthen.bak"); +exit} if($i{'erase'} eq 'safe'){&erase("$repnow.safe","$repthen.safe"); +exit} } # var names for 3 required files below use vars qw($xpdat1 $dat1 $then1 $thenxp1 $thent $now1 $nowxp1 $nowt); + # read from main data file if it exists, otherwise read from the netwo +rk. my$nodat = 0; my($xpdata,$data,$md); # vars for next block if(eval "require '$df'"){ # offline mode $md = (stat($df))[9]; $md = sprintf "<b>Data file updated:</b> %s<br>", scalar loca +ltime($md); $xpdata = $xpdat1; # hash containing parsed xp xml $data = $dat1; # hash containing parsed usernodes xml } else{$nodat = 1} # online mode # previous rep file my($then,$thenxp,$thentime,$then_is); if(($i{'n'}) && ($i{'n'} eq 'changes')){ if(eval "require '$repthen'"){ # old rep file $then_is = 1; $then = $then1; $thenxp = $thenxp1; $thentime = $thent; } } # present rep file my($now,$nowxp,$nowtime,$now_is); if(($i{'n'}) && ($i{'n'} eq 'changes')){ if(eval "require '$repnow'"){ # new rep file $now_is = 1; $now = $now1; $nowxp = $nowxp1; $nowtime = $nowt; } } my$ins = 0; if(($i{'n'}) && ($public_access ne 'yes')){ if($i{'n'} eq 'dumphash'){&dump_hash(); exit} # display raw data s +tructure if($i{'n'} eq 'login'){ if($i{'user'}){$ins++} if($i{'pass'}){$ins++} if($i{'pm'}){$ins++} if($i{'show'}){$ins++} } } if( ($i{'n'}) && ($public_access ne 'yes') ){ # set cookies if logout +or login if( ( ($i{'n'} eq 'login') && ($ins > 0) ) || ($i{'n'} eq 'logout' +) ){ my($c1,$c2,$c3,$c4,$s) = ''; if($i{'n'} eq 'login'){ if($i{'pm'}=~m|^(http://)|i){$i{'pm'}=~s/$1//o} $c1 = CGI::Cookie->new(-name=>'user',-value=>"$i{'user'}", +-expires=>'+10y'); $c2 = CGI::Cookie->new(-name=>'pass',-value=>"$i{'pass'}", +-expires=>'+10y'); $c3 = CGI::Cookie->new(-name=>'pm',-value=>"$i{'pm'}",-exp +ires=>'+10y'); $c4 = CGI::Cookie->new(-name=>'show',-value=>"$i{'show'}", +-expires=>'+10y'); } if($i{'n'} eq 'logout'){ $c1 = CGI::Cookie->new(-name=>'user',-value=>'',-expires=> +'now'); $c2 = CGI::Cookie->new(-name=>'pass',-value=>'',-expires=> +'now'); $c3 = CGI::Cookie->new(-name=>'pm',-value=>'',-expires=>'n +ow'); $c4 = CGI::Cookie->new(-name=>'show',-value=>'',-expires=> +'now'); } print header(-cookie=>[$c1,$c2,$c3,$c4]); unless($i{'n'} eq 'logout'){ if($ins > 1){$s='s'} &begin_html('fu'); print qq~$bq $bq $bq <h2>Cookie$s set</h2><b> username:</b> $i{'user'}<br><b> password:</b> <font size="-1">$i{'pass'}</font><br><b> perlmonks:</b> <a href="http://$i{'pm'}">$i{'pm'}</a><br>< +b> nodes per page:</b> $i{'show'}<br>~; my$err = 0; if( (!$i{'user'}) or (!$i{'pass'}) or (!$i{'pm'}) ){ print qq~<p><b><font color="#FF0000">Warning:</font> R +equired data missing!</b><ol>~; if(!$i{'user'}){ print '<li><b>username</b> required t +o access perlmonks.<br>'} if(!$i{'pass'}){ print '<li><b>password</b> required t +o access perlmonks.<br>'} if(!$i{'pm'}){ print '<li><b>perlmonks</b> domain requ +ired to access perlmonks.<br>'} print '</ol>'; $err++ } unless(($i{'pm'}) && ($i{'pm'}=~/\..*?\./)){ print qq~<p><font color="#FF0000"><b>Error</b>:</font> + <b>perlmonks</b> domain must have two dots!.~; $err++ } if( (!$i{'show'}) || (($i{'show'}) && ($i{'show'}!~/\d+/)) + ){ print qq~<p><font color="#FF0000"><b>Caution</b>:</fon +t> setting <b>nodes per page</b> to &lt; 1 or blank shows <i>all</i> nodes +.~; $err++ } if($nodat == 1){ print qq~<p><font color="#FF0000"><b><b>Data file not +detected.</b></b></font> <a href="$uri?n=make+data">Build a data file</a>?~; $err++ } if($err > 0){ print qq~<form method="$form_method"> <input type="hidden" name="n" value="login"> <input type="submit" value="login form"></form>~; } print qq~<p><font size="-1"><b>Note:</b> Setting a cookie +with incorrect username, password or perlmonks domain is fatal to authenticated dow +nloads (online mode functions: refresh and file creation) and will prompt to r +etry or login again. Bad login cookies do not interfere with offline operations.</f +ont>~; if($cookies{'ft'}){$fix_title = $cookies{'ft'}->value} if($cookies{'sr'}){$strip_re = $cookies{'sr'}->value} &print_form('z'); # print nav buttons, any arg just kicks +it into another mode print $eh; # end_html exit } } } my($username,$password,$show) = ''; if($public_access ne 'yes'){ if(($i{'n'}) && ($i{'n'} eq 'logout')){&login_form(); exit} } if(%cookies){ # get cookies if($cookies{'user'}){$username = $cookies{'user'}->value} if($cookies{'pass'}){$password = $cookies{'pass'}->value} if($cookies{'pm'}){$perlmonks = $cookies{'pm'}->value} if($cookies{'show'}){$show = $cookies{'show'}->value} if($cookies{'ft'}){$fix_title = $cookies{'ft'}->value} if($cookies{'sr'}){$strip_re = $cookies{'sr'}->value} } my$start = 1; if(($i{'start'}) && ($i{'start'}=~/\d+/)){$start = $i{'start'}} if(($i{'show'}) && ($i{'show'}=~/\d+/)){$show = $i{'show'}} if(defined($i{'ft'})){$fix_title = $i{'ft'}} if(defined($i{'sr'})){$strip_re = $i{'sr'}} # urls my$pmurl = "http://$perlmonks/index.pl"; my$repurl = "$pmurl?node_id=32704"; my$xpurl = "$pmurl?node_id=16046"; if($i{'n'}){ if($i{'n'} eq ' ? '){&help(); exit} if($public_access ne 'yes'){ if($i{'n'} eq 'update'){&check_update(); exit} if(($i{'n'} eq 'login') && ($ins < 1)){&begin_html(); &login_f +orm(); exit} if(($i{'n'} eq 'config') && ($nodat == 1)){&begin_html(); &con +fig(); exit} } } my($xml,$repxml,$xpxml,$avgrep,$modesc); # if data file doesn't exist or is being created or refreshed read xml + from network if( ($public_access ne 'yes') && ( ($nodat == 1) || ( ($i{'n'}) && ($i +{'n'}=~/make data/) ) ) ){ unless(($username=~/\S/) && ($password=~/\S/)){ &begin_html(); &login_form(); exit } &login(); # returns $repxml and $xpxml &fixxml($xpxml); # returns $xml $xpdata = XMLin($xml, keyattr => 'XP', forcearray => 1); &fixxml($repxml); # returns $xml $data = XMLin($xml, keyattr => 'NODE', forcearray => 1); } # extract xp info and username my($xp,$level,$xp2next,$xusername); if(defined @{$xpdata->{'XP'}}){ for my $xpinfo(@{$xpdata->{'XP'}}){ $xp2next = $xpinfo->{'xp2nextlevel'}; $level = $xpinfo->{'level'}; $xp = $xpinfo->{'xp'}; } } if(defined @{$xpdata->{'INFO'}}){ for my $xpinfo(@{$xpdata->{'INFO'}}){ $xusername = $xpinfo->{'foruser'}; } } my$begin_html = 0; # init header check my($mode,$td,$ta,$rd,$ra,$ca,$cd) = ''; if($i{'n'}){ # sub calls unless($public_access eq 'yes'){ if($i{'filename'}){ if($i{'n'} eq 'import data'){&import(); exit} } if($i{'n'} eq 'import'){&import_data(); exit} if($i{'n'} eq 'export'){&export_data(); exit} } if($i{'n'} eq 'gif'){&gif(); exit} # sort modes if($i{'n'} eq 'td'){$mode=$i{'n'}; $td='selected'} # title reverse if($i{'n'} eq 'ta'){$mode=$i{'n'}; $ta='selected'} # title if($i{'n'} eq 'rd'){$mode=$i{'n'}; $rd='selected'} # highest rep f +irst if($i{'n'} eq 'ra'){$mode=$i{'n'}; $ra='selected'} # lowest rep fi +rst if($i{'n'} eq 'ca'){$mode=$i{'n'}; $ca='selected'} # oldest first if($i{'n'} eq 'cd'){$mode=$i{'n'}; $cd='selected'} # newest first if($i{'n'} eq 'graph'){$mode='rd'; $rd='selected'} # graph - highe +st rep first } else{$mode='cd'; $cd='selected'} # default to newest first if no input my(%node_reps,%node_rep,%node_con,%node_cre,%rep_freq,%node_home); my(@reps,@reps_nodes,$total_nodes,$total_rep,$homenode); if(defined @{$data->{'NODE'}}){ my(@negs,@titles,@dates,$usersince); for my $node(@{$data->{'NODE'}}){ # find homenode $node_home{$node->{'id'}}=1 } my@hn = sort {$a <=> $b} keys %node_home; $homenode = $hn[0]; # by lowest node id for my $node(@{$data->{'NODE'}}){ if($node->{'id'} == $homenode){ $usersince = $node->{'createtime'} } unless($node->{'id'} == $homenode){ $rep_freq{$node->{'reputation'}}++; # frequency hash if($fix_title eq 'yes'){ $node->{'content'} =~ s/\($username\)//g; # strip user +name from node title } $node_con{$node->{'id'}} = $node->{'content'}; $node_cre{$node->{'id'}} = $node->{'createtime'}; $node_rep{$node->{'id'}} = $node->{'reputation'}; $node_reps{$node->{'id'}} = $node->{'reputation'}; $total_rep += $node->{'reputation'}; # total rep $total_nodes++; } } for(sort {$node_rep{$b} <=> $node_rep{$a}} keys %node_rep){ push @reps, $node_rep{$_}; # build a sorted array of node reps push @reps_nodes, $_; # and a parallel array of corresponding +node_ids } my$rephi = $reps[0]; my$replo = $reps[-1]; if(($i{'n'}) && ($public_access ne 'yes')){ # bailout before html +header if(($i{'n'} eq 'detect change') or ($i{'n'} eq 'detect')){&detect_ +changed_nodes(); exit} if(($i{'n'} eq 'restore') or ($i{'n'} eq 'restore previous')){&res +tore(); exit} if ($i{'n'} eq 'safe backup'){&safety('backup'); exit} if ($i{'n'} eq 'safe restore'){&safety('restore'); exit} } if(($show < 1) || ($show eq '')){$show = $total_nodes} if(($start < 1) || ($start eq '')){$start = 1} unless(($i{'re'}) && ($i{'re'}==1)){ &begin_html(); # html header, html start tags &the_bridge($total_rep,$xp,$rephi,$replo,$usersince); # display th +e summary and menu } if($i{'n'}){ # bailout after html header unless($public_access eq 'yes'){ if(($i{'n'} eq 'make data') || ($nodat == 1)){&makedat(); +exit} if($i{'n'} eq 'config'){&config(); exit} } if($i{'n'} eq 'changes'){&nowthen(); exit} if($i{'n'} eq 'graph'){&graph(); &the_bridge($total_rep,$xp,$rephi,$replo,$usersince); print $e +h; exit} } for(keys %modescs){ # find description of current sort mode if($_ eq $mode){ $modesc = $modescs{$mode} } } my($c,$d); if($mode=~/rd|ra/){ # by rep &listitle(); # print title corresponding to sort mode, opens t +able print qq~<tr bgcolor="#ffffff"> <td>num</td><td>title</td><td><b>rep</td><td>date</td></tr>~; + if($mode=~/ra/){ # ascend @reps = reverse(@reps); @reps_nodes = reverse(@reps_nodes); } my$r = '-1'; for(@reps){ $r++; $c++; if($c >= $start){ $d++; unless($d > $show){ if($strip_re eq 'yes'){$node_con{$reps_nodes[$r]}=~s/R +e: //g} print qq~<tr><td>$c</td> <td><a href='$pmurl?node_id=$reps_nodes[$r]'>$node +_con{$reps_nodes[$r]}</a></td> <td>$_</td> <td>$node_cre{$reps_nodes[$r]}</td></tr>~; } } } &nodes_per_page($start,$show,$c); } if($mode=~/td|ta/){ # by title &listitle(); print qq~<tr bgcolor="#ffffff"> <td>num</td><td><b>title</td><td>rep</td><td>date</td></tr>~; for(keys %node_con){ if($strip_re eq 'yes'){$node_con{$_}=~s/Re: //g} push @titles, $node_con{$_}."\t".$_ } if($mode=~/td/){@titles = sort { lc($b) cmp lc($a) } (@titles) +} # descend if($mode=~/ta/){@titles = sort { lc($a) cmp lc($b) } (@titles) +} # ascend for(@titles){ $c++; if($c >= $start){ $d++; unless($d > $show){ my($k,$v)=split(/\t/,$_); print qq~<tr><td>$c</td> <td><a href="$pmurl?node_id=$v">$k</a></td> <td align="right">$node_reps{$v}</td> <td>$node_cre{$v}</td></tr>~; } } } &nodes_per_page($start,$show,$c); } if($mode=~/cd|ca/){ # by date &listitle(); print qq~<tr bgcolor="#ffffff"> <td>num</td><td>title</td><td>rep</td><td><b>date</td></tr>~; for(keys %node_cre){ push @dates, $node_cre{$_}."\t".$_} if($mode=~/cd/){@dates = sort { lc($b) cmp lc($a) } (@dates)} +# descend if($mode=~/ca/){@dates = sort { lc($a) cmp lc($b) } (@dates)} +# ascend for(@dates){ $c++; if($c >= $start){ $d++; unless($d > $show){ my($k,$v)=split(/\t/,$_); if($strip_re eq 'yes'){$node_con{$v}=~s/Re: //g} print qq~<tr><td>$c</td> <td><a href='$pmurl?node_id=$v'>$node_con{$v}</a>< +/td> <td align='right'>$node_reps{$v}</td> <td>$node_cre{$v}</td></tr>~; } } } &nodes_per_page($start,$show,$c); } &the_bridge($total_rep,$xp,$rephi,$replo,$usersince); print $eh; exit } sub nodes_per_page { # construct the 'previous' and 'next' paging links my($start,$show,$c) = @_; my$previous = ($start-$show); print '</td></tr></table><div align="center"><table border="0"><tr><th +>'; unless($previous < 1){ # previous n print qq~<font size="-1"><a href="$uri?n=$mode&start=$previous&sho +w=$show~; if($fix_title eq 'yes'){ print qq~&ft=yes~} if($strip_re eq 'yes'){ print qq~&sr=yes~} print qq~">&lt;&lt; Prev $show</a></font>&nbsp;~; } my$Next = ($start+$show); # start and show form print qq~</th><form method="$form_method"><th align="right"> <input type="text" name="start" value="$start" size="3"> <input type="hidden" name="show" value="$show"> <input type="hidden" name="n" value="$mode"> </th></form><form method="$form_method"><th> <input type="text" name="show" value="$show" size="3"> <input type="hidden" name="start" value="$start"> <input type="hidden" name="n" value="$mode"></th></form><th>~; unless($Next > $c){ # next n print qq~&nbsp;<font size="-1"><a href="$uri?n=$mode&start=$Next&s +how=$show~; if($fix_title eq 'yes'){ print qq~&ft=yes~} if($strip_re eq 'yes'){ print qq~&sr=yes~} print qq~">Next $show &gt;&gt;</a></font>~; } print qq~<br></th></tr><tr><td colspan="2" align="right" valign="top"> +start </td> <td colspan="2" valign="top">show</td></tr></table></div><p>~; } sub login_form { my$state = shift; &begin_html('fu'); print qq~<form method="$form_method">$bq <h1>Login</h1>~; if($state eq 'config'){ print qq~<b>reputer creates 4 browser cookies</b><p> <b>1. username, 2. password,</b> and <b>3. perlmonks</b> are requi +red to read rep and xp data from the network, but aren't used when wor +king with saved files. <b>4. nodes per page</b> sets the page limit for + the sorted node list. If blank or set to 0 or less than 1 it shows all + nodes. Set a reasonable limit if you have a large number of nodes. +~; } unless($state eq 'config'){ print qq~Enter your <b>username, password</b> and <b>perlmonks</b> + domain here and select login. This saves browser cookies and prompts you to re +load reputer, which then uses the cookie info for further interaction w +ith perlmonks. The <b>'nodes per page'</b> cookie defines the length o +f the node list. Logout deletes these browser cookies.<p> <font size="-1">Note: username, password and perlmonks domain are +required to acquire data.</font>~; } if(($username!~/\S/) || ($password!~/\S/)){ unless(($i{'n'}) && ($i{'n'} eq 'logout')){ print '<p><font color="#ff0000"><b>Warning:</b></font><ol>'; unless($username=~/\S/){ print "<li>username required"} unless($password=~/\S/){ print "<li>password required"} unless($perlmonks=~/^.*?\..*?\..*?$/){ print "<li>perlmonks do +main required (with two dots)"} } } print qq~<p> <input type="text" name="user" size=22 value="$username"> <b>username< +/b><br> <input type="text" name="pass" size=22 value="$password"> <b>password< +/b><br><p> <font size="-1">Set to your usual login domain.<br></font> <input type="text" name="pm" size=22 value="$perlmonks"> <b>perlmonks< +/b><br> <font size="-1">Must have at least two dots.<br></font><p> <input type="text" name="show" size="3" value="$show"> <b>nodes per pa +ge</b><br> <input type="submit" name="n" value="login"> <input type="submit" name="n" value="logout">~; if(($i{'n'}) && ($i{'n'} ne 'config')){ print ' <input type="submit" n +ame="n" value=" ? ">'} print "</form></blockquote> $eh"; } sub login { # login and download rep and xp xml files my$state = shift; my$ua = LWP::UserAgent->new; # create a web browser object (useragent) $ua->agent("reputer/$info{'version'}"); # call it reputer $ua->cookie_jar(HTTP::Cookies->new()); # enable cookies $ua->proxy(http=>"$proxy") if ($use_proxy eq 'yes'); # proxy # build a request object, returns cookies my$req = POST ($pmurl, [op=>'login',user=>$username,passwd=>$password, +expires=>'+10y',node_id=>'16046']); if($use_proxy eq 'yes'){$req->proxy_authorization_basic("$proxyid", "$ +proxypass")} # proxy my$res = $ua->request($req); # make request $req = GET ($repurl); # build new request (user rep data) if($use_proxy eq 'yes'){$req->proxy_authorization_basic("$proxyid", "$ +proxypass")} # proxy $res = $ua->request($req); # make request $repxml = $res->content; # extract content of response unless($repxml=~/\S/){ if($state eq 'detect'){ # restore if download fails &restore(); select($handle); &begin_html($metac); print qq~Download failed. Previous view restored, <a href="$uri?n=changes">reloading...</a>~; exit } else{ unless($begin_html == 1){&begin_html()} print qq~$bq Rep download failed, try again or <a href="$uri?n=login">login</a>.~; exit } } $req = GET ($xpurl); # make new request (user rep data) if($use_proxy eq 'yes'){$req->proxy_authorization_basic("$proxyid", "$ +proxypass")} # proxy $res = $ua->request($req); $xpxml = $res->content; unless($xpxml=~/\S/){ unless($begin_html == 1){&begin_html()} print qq~$bq XP download failed, try again or <a href="$uri?n=login">login</a>.~; exit } return } sub detect_changed_nodes { &copy($repthen,"$repthen.bak"); &copy($repnow,"$repnow.bak"); open(OLD,"< $repnow") or die "$!"; open(TMP,"> $repthen") or die "$!"; select(TMP); while(<OLD>){ # repnow -> (fix variables) -> repthen $_=~s/\$nowxp1 = \{/\$thenxp1 = \{/o; $_=~s/\$now1 = \{/\$then1 = \{/o; $_=~s/\$nowt = '/\$thent = '/o; print TMP $_; } close(OLD) or die "$!"; close(TMP) or die "$!"; select($handle); &getsave($repnow,'nowxp','now','nowt','detect'); &getsave($df,'xpdat','dat','makedat'); # also update node list data fi +le &begin_html($metac); print qq~Download complete, <a href="$uri?n=changes">analyzing...</a>~ +; } sub program_list { # list external programs if(($public_access ne 'yes') && (defined %programs)){ print qq~<table border="0" cellpadding="2" cellspacing="1" bgcolor +="#bbbbbb" width="100%"> <tr>~; for(sort {$b cmp $a} keys %programs){ my$g = $_; $g =~ tr/ /+/; print qq~<td align="center"><a href="$uri?exec=$g">$_</a></td> +~; } print qq~</tr></table>~; } } sub install_xml_simple { print header; print qq~Install <a href='http://search.cpan.org/search?dist=XML-Simple'>XML::Simple</a +>~; } sub fixxml { # replace ascii chrs that are not legal xml with underscore # nodes with title like this would break links back to the node $xml = shift; $xml =~ s/[\r\n\t]//g; # jcwren $xml =~ tr/\x80-\xff/_/; # $xml =~ tr/\x00-\x1f/_/; # return $xml; } sub getsave { # save data files according to passed parameters my$state = $_[4]; unless(($i{'n'} eq 'make data') || ($nodat == 1)){ &login($state); # returns $repxml and $xpxml &fixxml($xpxml); # returns $xml $xpdata = XMLin($xml, keyattr => 'XP', forcearray => 1); &fixxml($repxml); # returns $xml $data = XMLin($xml, keyattr => 'NODE', forcearray => 1); } open(DAT,"> $_[0]") or die "$!"; $Data::Dumper::Indent = $ddi; $Data::Dumper::Varname = "$_[1]"; print DAT Dumper($xpdata); $Data::Dumper::Indent = $ddi; $Data::Dumper::Varname = "$_[2]"; print DAT Dumper($data); print DAT '$'.$_[3]." = '$today';"; close(DAT) or die "$!"; } sub filedata { # find and print file size and createtime my$size = (-s $_[0]); my$when = (stat($_[0]))[9]; $when = sprintf "%s", scalar localtime($when); print '<tt> - '.$size.' bytes, created '.$when.'</tt><br>'; } sub copy { # simple file copy if(-e $_[0]){ open(OLD,"< $_[0]") or die "$!"; } else{ &begin_html($metad); print "$_[0] doesn't exist"; exit } open(NEW,"> $_[1]") or die "$!"; select(NEW); while(<OLD>){ print NEW $_ } close(OLD) or die "$!"; close(NEW) or die "$!"; select($handle); } sub erase { # erase passed files and print results &begin_html($metad,'<ol>'); for(@_){ if(-e $_){ unlink $_; print "<li>$_ deleted"; } else { print "<li>$_ doesn't exist"; } } print "</ol><p><a href='$uri?n=config'>Reloading...</a>"; } sub restore { # restore previous view &copy("$repthen.bak",$repthen); &copy("$repnow.bak",$repnow); if($i{'n'}=~/restore/){ select($handle); &begin_html($metac); print qq~Previous restored, <a href="$uri?n=changes">reloading...< +/a>~; exit } } sub safety { # make or restore from safe backup my$state = shift; if($state eq 'backup'){ &copy($repthen,"$repthen.safe"); &copy($repnow,"$repnow.safe"); &begin_html($metac); print qq~Saved to the safe backup, <a href="$uri?n=changes">reload +ing...</a>~; } if($state eq 'restore'){ &copy("$repthen.safe",$repthen); &copy("$repnow.safe",$repnow); &begin_html($metac); print qq~Safe backup restored, <a href="$uri?n=changes">reloading. +..</a>~; } } sub makedat { # make the main data file &getsave($df,'xpdat','dat','makedat'); unless($i{'re'}==1){ print qq~<p> $bq <b>Data file $df created.</b><p> Further access will use this data file until it's <a href="$uri?n=make+data">refreshed</a> or overwritten.~; } if($i{'re'}==1){ print "Location: $uri?n=$i{'mode'}\n\n"} } sub import { # function open(DAT,"< $i{'filename'}") or die "$!"; local $/ = undef; my$imports = <DAT>; close(DAT) or die "$!"; &begin_html(); unless($imports=~/^M/){ print qq~<p>$bq Invalid data in $i{'filename'}.<br> Must be uuencoded data...~; exit } $imports = unpack ("u", $imports); # uudecode $imports = uncompress($imports); # uncompress unless(defined($imports)){ print qq~<p>$bq Invalid data in $i{'filename'}.<br> Must be zlib compressed data...~; exit } open(DAT,"> $df") or die "$!"; print DAT $imports; close(DAT) or die "$!"; print qq~<p> $bq <b>$i{'filename'}</b> imported and saved as <b>$df</b><p> Sorted node list will read from this file until it's overwritten by 'refresh', 'detect change' or 'import'. <form method="$form_method"> Return to <input type="submit" name="n" value="config"></form> $eh~; } sub import_data { # menu my@dir; opendir THIS, "$temp" or die "$!"; while(defined ($_ = readdir(THIS))){ next unless $_ =~ m|reputer-(.*?)\.export|; push @dir, $_; } closedir THIS or die "$!"; @dir = sort { lc($a) cmp lc($b) } @dir; &begin_html(); print qq~<table border="1" cellpadding="6" cellspacing="0"> <tr><th align="left" colspan="2"><h2>Import</h2></td></tr> <tr><form method="$form_method"><td> Showing files named<p> <b>reputer-username.export</b> <p> in the temp dir ($temp). <p>Importing a file overwrites the<br> current data file ($df), and allows <br> viewing and sorting the imported nodes.<br></td><td> <select name="filename" size="10">~; for(@dir){ print "<option value='$_'>$_"; } print qq~</select><br> <input type="submit" name="n" value="import data"> <input type="submit" name="n" value="config"></td></form></tr></table> + $eh~; exit } sub export_data { my($size1,$size2); open(DAT,"< $df") or die "$!"; local $/ = undef; my$exports = <DAT>; close(DAT) or die "$!"; $size1 = (-s($df)); $exports = compress($exports); # compress unless(defined($exports)){ print qq~<p>$bq zlib compression failed...~; exit } $exports = pack ("u", $exports); # uuencode $xusername =~ tr/ /+/; if($xusername=~/^([-\@\w.]+)$/){$xusername=$1} # untaint filename else{ die "Error! Can't use $xusername as part of the filename."} my$ef = $temp."reputer-$xusername.export"; unless($i{'e'} eq 'screen'){ open(DAT,"> $ef") or die "$!"; print DAT $exports; close(DAT) or die "$!"; $size2 = (-s($ef)); } if($i{'e'} eq 'screen'){ $size2 = length($exports); } my$fu = sprintf("%d",(($size2/$size1)*100)); $exports = encode_entities($exports); my$lines = $exports =~ tr/\n/\n/; $lines = ($lines/2); # testarea rows &begin_html(); print '<div align="right"'; &print_nav('z'); print qq~</div>\n <!-- CUT AND PASTE FROM THE TEXTAREA, NOT THE HTML SOURCE -->\n <p><form>Data exported~; unless($i{'e'} eq 'screen'){ print qq~ to <a href="$ef"><tt>$ef</tt></a>~; } print qq~<br> original $size1 bytes, exported $size2 bytes ($fu%)<br> <textarea cols='70' rows='$lines'>$exports<\/textarea></form>~; } sub dump_hash { # display raw data structure print header('text/plain'); $Data::Dumper::Varname = "xpdat"; print Dumper($xpdata); $Data::Dumper::Varname = "dat"; print Dumper($data); } sub begin_html { # print document html headers my($metatag,$content) = @_; unless(($metatag) && ($metatag eq 'fu')){ if( ($i{'show'}) || ($i{'ft'}) || ($i{'sr'}) ){ my($sc,$ft,$sr); if($i{'show'}){ $sc = CGI::Cookie->new(-name=>'show',-value=>"$i{'show'}", +-expires=>'+10y'); } if( ($i{'ft'}) && ($i{'ft'} eq 'yes') ){ $fix_title = 'yes'; $ft = CGI::Cookie->new(-name=>'ft',-value=>'yes',-expires= +>'+10y'); } else{$ft = CGI::Cookie->new(-name=>'ft',-value=>'no',-expires= +>'now'); $fix_title = 'no'} if( ($i{'sr'}) && ($i{'sr'} eq 'yes') ){ $strip_re = 'yes'; $sr = CGI::Cookie->new(-name=>'sr',-value=>'yes',-expires= +>'+10y'); } else{$sr = CGI::Cookie->new(-name=>'sr',-value=>'no',-expires= +>'now'); $strip_re = 'no'} print header(-cookie=>[$sc,$ft,$sr]); } else{ print header } } if($metatag eq 'fu'){ undef($metatag)} print qq~<html><head><title>reputer</title> $metatag <style><!-- td{ font-family:arial;font-size:80%; }// --></style></head +> $bodytag $content~; $begin_html = 1; } sub the_bridge { # print the summary/menu print qq~<table border="0" cellpadding="2" cellspacing="0" bgcolor="#d +0d0d0" width="100%"> <tr><td valign="top">~; &summary(@_); print '</td><td valign="middle" align="right">'; &print_form(); print '</td></tr></table>'; &program_list(); # list external programs } sub gif { # a gif for the graph local $| = 0; print "Content-type: image/gif\n\n", pack "H*", "47494638396101000100800000ffffff". "00000021f90401000000002c00000000". "010001000002024401003b"; } sub print_form { # sort form my$bit = shift; my($ftc,$src) = ''; print qq~<FORM method="$form_method"> <SELECT NAME="n" size="1"> <OPTION $cd VALUE="cd">$modescs{'cd'} <OPTION $ca VALUE="ca">$modescs{'ca'} <OPTION $rd VALUE="rd">$modescs{'rd'} <OPTION $ra VALUE="ra">$modescs{'ra'} <OPTION $ta VALUE="ta">$modescs{'ta'} <OPTION $td VALUE="td">$modescs{'td'}</SELECT>~; if($show eq ''){$show = 0} if($start eq ''){$start = 1} print qq~<input type="hidden" name="show" value="$show"> <input type="hidden" name="start" value="$start"> <INPUT TYPE="submit" VALUE="Sort"><br>~; if($fix_title eq 'yes'){$ftc = ' checked'} if($strip_re eq 'yes'){$src = ' checked'} print qq~<b>strip:</b> <input type="checkbox" name="ft" value="yes"$ft +c> username <input type="checkbox" name="sr" value="yes"$src> re</FORM>~; &print_nav($bit); } sub print_nav { # navigation buttons my$bit = shift; print "<FORM method='$form_method'>"; print '<INPUT TYPE="submit" name="n" VALUE=" ? "> '; unless($public_access eq 'yes'){ print '<INPUT TYPE="submit" name="n" VALUE="config"> ' } print '<INPUT TYPE="submit" name="n" VALUE="changes"> '. '<INPUT TYPE="submit" name="n" VALUE="graph"></FORM>'; unless($bit){ if($nodat!=1){ print qq~<b>Today:</b> $today<br>$md~}} } sub listitle { print qq~<p> <table border="$bb" cellpadding="2" cellspacing="1" bgcolor="#d0d0d0" +width="100%"> <tr><th colspan="3" align="left"><h2>Nodes sorted by $modesc</h2></th> <td align="right" valign="top"><form method="$form_method"> <input type="hidden" name="n" value="make data"> <input type="hidden" name="mode" value="$mode"> <input type="hidden" name="re" value="1">~; unless($public_access eq 'yes'){ print '<input type="submit" value="Refresh">' } print '&nbsp;</form></td></tr>'; } sub help { &begin_html(undef,'<div align="right">'); &print_form('z'); my$self = -s $0; if($show eq ''){$show = 0} if($start eq ''){$start = 1} print qq~</div> $bq <h1>reputer $info{'version'}</h1> Because of it's size ($self bytes) reputer has two nodes on <a href="$ +pmurl">Perlmonks</a>. <ul><li><a href="$pmurl?node=reputer">The source code is here</a> in t +he code catacombs. <li>Please make replies to <a href="$pmurl?node=reputer+reply">this cr +osslinked reply node</a>.</ul> <p><FORM method="$form_method"> <h2>Sort</h2> <SELECT NAME="n" size="1"> <OPTION $cd VALUE="cd">$modescs{'cd'} <OPTION $ca VALUE="ca">$modescs{'ca'} <OPTION $rd VALUE="rd">$modescs{'rd'} <OPTION $ra VALUE="ra">$modescs{'ra'} <OPTION $ta VALUE="ta">$modescs{'ta'} <OPTION $td VALUE="td">$modescs{'td'}</SELECT> <input type="hidden" name="show" value="$show"> <input type="hidden" name="start" value="$start"> <INPUT TYPE="submit" VALUE="Sort"><br>~; my($ftc,$src) = ''; if($fix_title eq 'yes'){$ftc = ' checked'} if($strip_re eq 'yes'){$src = ' checked'} print qq~<font size="-1"><b>strip:</b> <input type="checkbox" name="ft +" value="yes"$ftc> username <input type="checkbox" name="sr" value="yes"$src> re</font><p +> <b>The default screen. Sort nodes by date, reputation or title.</b> <ul> <li>Option to strip <i>($username)</i> and <i>Re:</i> from node titles +.~; if($public_access ne 'yes'){ print qq~<li>Refresh button updates the node list with fresh data +from perlmonks.~} print qq~</ul></FORM><FORM method="$form_method"> <h2>Graph</h2> <INPUT TYPE="submit" name="n" VALUE="graph"><p> <b>Graph number of nodes by reputation.</b> <ul> <li>Avg reputation is highlighted only if there is at least one node a +t that rep. </ul> <h2>Changes</h2> <INPUT TYPE="submit" name="n" VALUE="changes"><p>~; if($public_access ne 'yes'){ print qq~<b>Detect new, changed and deleted nodes.</b><br> <ul> <li>Display detailed statistics. Undo and backup. <li>Selecting 'detect change' twice wipes out 'restore previous'. </ul>~; } if($public_access eq 'yes'){ print qq~Display new, changed and deleted nodes with<br> detailed statistics.~; } print qq~<br></FORM>~; unless($public_access eq 'yes'){ print qq~<FORM method="$form_method"><h2>Config</h2> <INPUT TYPE="submit" name="n" VALUE="config"><p> <b>Manage cookies and files, check for updates.</b></FORM>~; } print qq~<p align="right">coded by <a href="$pmurl?node=epoptai">epopt +ai</a>~; } sub config { # configuration menu my%exists; my@files = ( "$df","$repnow","$repthen","$repnow.bak","$repthen.bak", "$repnow.safe", "$repthen.safe","reputer-$xusername.export"); for(@files){ if(-e $_){$exists{$_}=1} else {$exists{$_}=0}} $info{'date'}=~s/(....)(..)(..)/$1-$2-$3/o; print qq~<table width="100%" border="0" bgcolor="#ffffff" cellpadding= +"4" cellspacing="0"> <tr><th align="left"><h1>Configure</h1></th></tr></table> $bq~; &login_form('config'); print qq~<hr><form method="$form_method"><h1>Files</h1> <i>reputer creates up to 8 data files</i> <h3>A file used for the sortable node list:</h3> <b>reputer.dat</b>~; if($exists{$df}==1){&filedata($df)} else{ print " - doesn't exist<br>" +} print qq~<li> <input type="hidden" name="n" value="make data"> <input type="submit" value="refresh"> - refresh node, reputation and xp data file</FORM>~; if($exists{$df}==1){ print qq~<form method="$form_method"> <input type="hidden" name="n" value="dumphash"> <li><input type="submit" value="dump"> - dump the raw data structu +re to screen</form>~} if($trade!=1){ print qq~Install <a href='http://search.cpan.org/search?dist=Compr +ess-Zlib'> Compress::Zlib</a> to enable import and export functions.~} if($trade==1){ my$size; $xusername =~ tr/ /+/; if(-e $files[7]){$size = (-s $files[7])} else{$size = ((-s $files[0])/3)} $size = sprintf("%d", $size); if($exists{$df}==1){ print qq~<form method="$form_method"> <b>Export/import a compressed data file containing node, reput +ation and xp data.</b><p> <li><INPUT TYPE="submit" name="n" VALUE="export"> - export $df as <i>$files[7]</i> ($size bytes).<br> <INPUT TYPE="checkbox" name="e" VALUE="screen"> <font size="-1 +">don't save, display only</font><p> <li><INPUT TYPE="submit" name="n" VALUE="import"> - select a file to import, overwrites $df</FORM>~; } } print qq~<hr> <FORM method="$form_method"><input type="hidden" name="erase" value="c +urrent"> <h3>A pair of lists for <i>'changes':</i></h3> <b>reputer.now</b>~; if($exists{$repnow}==1){&filedata($repnow)} else{ print " - doesn't ex +ist<br>"} print '<b>reputer.then</b>'; if($exists{$repthen}==1){&filedata($repthen)} else{ print " - doesn't +exist<br>"} if(($exists{$repnow}==1) && ($exists{$repthen}==1)){ print '<INPUT TYPE="submit" VALUE="delete">' } print qq~</FORM><hr><FORM method="$form_method"> <input type="hidden" name="erase" value="backup"> <h3>A pair of lists for <i>'previous view':</i></h3> <b>reputer.now.bak</b>~; if($exists{"$repnow.bak"}==1){&filedata("$repnow.bak")} else{ print " +- doesn't exist<br>"} print '<b>reputer.then.bak</b>'; if($exists{"$repthen.bak"}==1){&filedata("$repthen.bak")} else{ print +" - doesn't exist<br>"} if(($exists{"$repnow.bak"}==1) && ($exists{"$repthen.bak"}==1)){ print '<INPUT TYPE="submit" name="n" VALUE="delete">' } print '</form>'; if(($exists{"$repnow.bak"}==1) && ($exists{"$repthen.bak"}==1)){ print qq~<FORM method="$form_method"><INPUT TYPE="submit" name="n" + VALUE="restore previous"> - replace the <i>changes</i> pair with these files.<hr></FORM>~} else{ print '<hr>'} print qq~<FORM method="$form_method"><input type="hidden" name="erase" + value="safe"> <h3>A pair of lists for <i>'safe backup':</i></h3><b>reputer.now.safe< +/b>~; if($exists{"$repnow.safe"}==1){&filedata("$repnow.safe")} else{ print +" - doesn't exist<br>"} print '<b>reputer.then.safe</b>'; if($exists{"$repthen.safe"}==1){&filedata("$repthen.safe")} else{ prin +t " - doesn't exist<br>"} if(($exists{"$repnow.safe"}==1) && ($exists{"$repthen.safe"}==1)){ print '<INPUT TYPE="submit" name="n" VALUE="delete">' } print '</form>'; if(($exists{"$repnow.safe"}==1) && ($exists{"$repthen.safe"}==1)){ print qq~<FORM method="$form_method"><INPUT TYPE="submit" name="n" + VALUE="safe restore"> - replace the <i>changes</i> pair with these files.<hr></FORM>~} else{ print '<hr>'} print qq~<form method="$form_method"><h1>Updates</h1> This is version $info{'version'} ($info{'date'}). Check for an <input type="submit" name="n" value="update"></form>~; print $eh; } sub check_update { # looks for <!--INFO:version=n,date=yyyymmdd--> on code node # and compares it with version data from the %info hash my$check_rev; my$check = get 'http://www.perlmonks.org/index.pl?node_id=69581'; if($check !~ /\S/){ &begin_html(); print qq~$bq Download failed, <a href="$uri?n=update">try again?</ +a>~; &print_nav('z'); exit } unless($check =~ /<!--INFO:/){ &begin_html(); print qq~$bq Version information not detected, try again later or +go to the <a href="$pmurl?node=reputer">reputer homenode</a>.~; &print_nav('z'); exit } my@check = split /\n/, $check; @check = grep /<!--INFO:.*?-->/, @check; $check = $check[0]; $check =~ s/<!--INFO://o; $check =~ s/-->//o; @check = split /,/, $check; my$cnt = (@check+1); for(@check){ my($k,$v) = split /=/, $_; if($k eq 'version'){$check_rev = $v} } &begin_html(); print qq~<table border="1" cellpadding="6" cellspacing="1"> <tr bgcolor="#ffffff"><th colspan="$cnt"><h1>~; if($check_rev > $info{'version'}){ print qq~Update Available~} if($check_rev == $info{'version'}){ print qq~This is the current ve +rsion~} if($check_rev < $info{'version'}){ print qq~This version newer than up +date!~} print '</h1></td></tr><tr bgcolor="#cccccc"><th>&nbsp;</th>'; for(@check){ my($k,$v) = split /=/, $_; print qq~<th>$k</th>~ } if($check_rev < $info{'version'}){ print qq~</tr><tr><th align="right"><a href="$pmurl?node=reputer"> +Downgrade</a> </th>~ } else{ print qq~</tr><tr><th align="right"><a href="$pmurl?node=reputer"> +Update</a> </th>~ } for(@check){ # update my($k,$v) = split /=/, $_; if($k=~/date/){$v=~s/(....)(..)(..)/$1-$2-$3/o} print qq~<td align="center">$v</td>~ } print '</tr><tr><th align="right">This </th>'; for(@check){ # this my($k,$v) = split /=/, $_; if($k=~/date/){$info{$k}=~s/(....)(..)(..)/$1-$2-$3/o} print qq~<td align="center">$info{$k}</td>~ } print '</tr></table>'; &print_nav('z'); } sub nowthen { # calculate changed nodes if(($then_is != 1) or ($now_is != 1)){ &getsave($repthen,'thenxp','then','thent'); &getsave($repnow,'nowxp','now','nowt'); print qq~<p>$bq Files created, try again later by selecting 'detec +t change'.<p> Select <a href="$uri?n=changes">changes</a> again to see a summary +.~; exit } my(%repgain,%reploss,%repthen,%repnow,%thenall,%nowall); my(%now_content,%now_created,%now_rep,%then_content,%then_created,%the +n_rep); my$many = 0; # changed nodes # extract xp info my($now_xp2nxt,$now_level,$now_xp); for my $xpnow(@{$nowxp->{'XP'}}){ # now $now_xp2nxt = $xpnow->{'xp2nextlevel'}; $now_level = $xpnow->{'level'}; $now_xp = $xpnow->{'xp'}; } my($then_xp2nxt,$then_level,$then_xp); for my $xpthen(@{$thenxp->{'XP'}}){ # then $then_xp2nxt = $xpthen->{'xp2nextlevel'}; $then_level = $xpthen->{'level'}; $then_xp = $xpthen->{'xp'}; } my($now_arts,$now_trep,$then_arts,$then_trep) = 0; for my $then (@{$then->{'NODE'}}){ $then_trep += $then->{'reputation'}; # total rep then $then_arts++; } # unravel the data into a bunch of hashes keyed on node_id for my $now (@{$now->{'NODE'}}){ # now $now_content{$now->{'id'}} = $now->{'content'}; $now_created{$now->{'id'}} = $now->{'createtime'}; $now_rep{$now->{'id'}} = $now->{'reputation'}; $now_trep += $now->{'reputation'}; # total rep now $now_arts++; for my $then (@{$then->{'NODE'}}){ # then $then_content{$then->{'id'}} = $then->{'content'}; $then_created{$then->{'id'}} = $then->{'createtime'}; $then_rep{$then->{'id'}} = $then->{'reputation'}; if($now->{'id'} == $then->{'id'}){ if($now->{'reputation'} > $then->{'reputation'}){ # gain $repgain{$now->{'id'}} = ($now->{'reputation'} - $then +->{'reputation'}); $repthen{$now->{'id'}} = $then->{'reputation'}; $repnow{$now->{'id'}} = $now->{'reputation'}; $many++; } if($now->{'reputation'} < $then->{'reputation'}){ # loss $reploss{$now->{'id'}} = ($then->{'reputation'} - $now +->{'reputation'}); $repthen{$now->{'id'}} = $then->{'reputation'}; $repnow{$now->{'id'}} = $now->{'reputation'}; $many++; } } $thenall{$then->{'id'}} = $then->{'reputation'}; } $nowall{$now->{'id'}} = $now->{'reputation'}; } my(@newnodes,@delnodes,@thenreps,@nowreps) = (); for(sort {$b <=> $a} keys %nowall){ # new nodes push (@nowreps, $nowall{$_}); push (@newnodes, $_) unless exists $thenall{$_}; } for(sort {$b <=> $a} keys %thenall){ # deleted nodes push (@thenreps, $thenall{$_}); push (@delnodes, $_) unless exists $nowall{$_}; } # calculate the results of the rep/xp comparison till next print @nowreps = sort {$b <=> $a} @nowreps; @thenreps = sort {$b <=> $a} @thenreps; $now_arts = (scalar(@nowreps)-1); # subtract homenode from total $then_arts = (scalar(@thenreps)-1); my$change_arts = ($now_arts-$then_arts); my$change_reps = ($now_trep-$then_trep); my$change_xp = ($now_xp-$then_xp); my$nn = 0; if(($many == 0) && ($change_arts != 0)){$many = $change_arts; $nn = 1} + my$thenavg = sprintf ("%3.2f", $then_trep / $then_arts); my$nowavg = sprintf ("%3.2f", $now_trep / $now_arts); my$change_avg = sprintf ("%3.2f", ($nowavg-$thenavg)); my$change_max = ($nowreps[0]-$thenreps[0]); my$change_min = ($nowreps[-1]-$thenreps[-1]); if($change_arts > 0){$change_arts = '+'.$change_arts} if($change_reps > 0){$change_reps = '+'.$change_reps} if($change_xp > 0){$change_xp = '+'.$change_xp} if($change_avg > 0){$change_avg = '+'.$change_avg} if($change_max > 0){$change_max = '+'.$change_max} if($change_min > 0){$change_min = '+'.$change_min} my$sz = 1; # size of select menu my($e1,$e2,$e3); if( (-e $repthen) && (-e $repnow) ){ $sz++; $e1=1 } # if file exists i +ncrease select menu size & list item if( (-e "$repthen.bak") && (-e "$repnow.bak") ){ $sz++; $e2=1 } if( (-e "$repthen.safe") && (-e "$repnow.safe") ){ $sz++; $e3=1 } print qq~<table border="0" cellpadding="2" cellspacing="0" bgcolor="#b +0b0b0" width="100%"> <tr><form method="$form_method"><td valign="middle">~; unless($public_access eq 'yes'){ print qq~<select name="n" size="$sz"> <option value="detect change"> detect change~; if($e2 == 1){ print '<option value="restore previous"> restore pre +vious'} if($e1 == 1){ print '<option value="safe backup"> safe backup'} if($e3 == 1){ print '<option value="safe restore"> safe restore'} print '</select><input type="submit" value="Go">'; } print qq~&nbsp;</td></form><th><h1>changes</h1></th><td align="right"> +<b> Then:</b> $thentime<br><b>Now:</b> $nowtime<br></td></tr></table><p> <table border="$bb" cellpadding="2" cellspacing="1" bgcolor="#b0b0b0" +width="100%"> <tr align="right" bgcolor="#ffffff"><td>&nbsp;</td><td>then</td><td>no +w</td><td>change</td></tr>~; &change_sum($change_arts,'Total nodes',$then_arts,$now_arts,$change_ar +ts); &change_sum($change_reps,'Total reputation',$then_trep,$now_trep,$chan +ge_reps); &change_sum($change_xp,'Total experience',$then_xp,$now_xp,$change_xp) +; &change_sum($change_max,'Max reputation',$thenreps[0],$nowreps[0],$cha +nge_max); &change_sum($change_avg,'Avg reputation',$thenavg,$nowavg,$change_avg) +; &change_sum($change_min,'Min reputation',$thenreps[-1],$nowreps[-1],$c +hange_min); print qq~</table><p> <table border="$bb" cellpadding="2" cellspacing="1" bgcolor="#b0b0b0" +width="100%">~; my(@trc,$trc); # total rep from changed nodes if(($many == 0) && ($nn == 0)){ # no changed nodes my($rp,$sr) = ''; if((-e "$repthen.bak") && (-e "$repnow.bak")){ $rp = '<input type="submit" name="n" value="restore previous"> +'; } if((-e "$repthen.safe") && (-e "$repnow.safe")){ $sr = '<input type="submit" name="n" value="safe restore">'; } print qq~<p>$bq No changed nodes. Try again later. <p><form method="$form_method"> $rp $sr </form>~; exit } if(($many > 0) && ($nn == 0)){ # changed nodes print qq~<tr><td colspan="6"><b>Changed</b></td></tr> <tr><td>node</td><td>title</td><td>created</td><td>then</td><td>no +w</td><td>change</td></tr>~; } for my $foo (sort {$b <=> $a} keys %nowall){ # sort by node id for my $gain (sort {$b <=> $a} keys %repgain){ # gain if($gain == $foo){ print qq~<tr bgcolor="#ffffff" align="center"><td>$gain </ +td> <td align="left"> <a href="$pmurl?node_id=$gain">$now_cont +ent{$gain}</a> </td> <td> <small>$now_created{$gain}</small> </td> <td> $repthen{$gain} </td> <td> $repnow{$gain} </td> <td> +$repgain{$gain}</td></tr>~; push @trc, $repgain{$gain} } } for my $loss (sort {$b <=> $a} keys %reploss){ # loss if($loss == $foo){ print qq~<tr bgcolor="#ffbbbb" align="center"><td>$loss </ +td> <td align="left"> <a href="$pmurl?node_id=$loss">$now_cont +ent{$loss}</a> </td> <td> <small>$now_created{$loss}</small> </td> <td> $repthen{$loss} </td> <td> $repnow{$loss} </td> <td> -$reploss{$loss}</td></tr>~; push @trc, '-'.$reploss{$loss} } } } if(@newnodes){ # new nodes print qq~<tr><td colspan="6"><b>New</b></td></tr> <tr><td>node</td><td>title</td><td>created</td> <td>then</td><td>now</td><td>change</td></tr>~; for my $foo (sort {$b <=> $a} keys %nowall){ for(@newnodes){ my$color = '#ffffff'; my$pref = '+'; if($_ == $foo){ if($now_rep{$_} == 0){ $pref = ''} if($now_rep{$_} > 0){ $pref = '+'} if($now_rep{$_} < 0){ $color = '#ffbbbb'; $pref = ''} print qq~<tr bgcolor="$color" align="center"><td>$_ </ +td> <td align="left"> <a href="$pmurl?node_id=$_">$now_con +tent{$_}</a> </td> <td> <small>$now_created{$_}</small> </td> <td> 0 </td> <td> $now_rep{$_} </td> <td> $pref$now_rep{$_}</td></tr>~; push @trc, $now_rep{$_} } } } } if(@delnodes){ # deleted nodes print qq~<tr><td colspan="6"><b>Deleted</b></td></tr> <tr><td>node</td><td>title</td><td>created</td> <td>then</td><td>now</td><td>change</td></tr>~; for my $foo (sort {$b <=> $a} keys %thenall){ for(@delnodes){ my$color = '#ffffff'; if($_ == $foo){ print qq~<tr bgcolor="$color" align="center"><td>$_ </ +td> <td align="left"> <a href="$pmurl?node_id=$_">$then_co +ntent{$_}</a> </td> <td> <small>$then_created{$_}</small> </td> <td> $then_rep{$_} </td> <td> &nbsp; </td> <td> &nbsp;</td></tr>~; } } } } for(@trc){$trc += $_} # total rep from changed nodes $trc[0] = '#bbbbbb'; if($trc > 0){$trc = '+'.$trc} if($trc < 0){$trc[0] = '#ffbbbb'} print qq~<tr align="center" valign="bottom" bgcolor="$trc[0]"> <td colspan="5" align="right"><p><br>Total experience from node change +s</td> <td>$trc</td></tr></table> $eh~; } # end sub nowthen sub summary { # totals and averages section of the main menu my$total_rep = shift; # had to shift to get them all my$xp = shift; my$rephi = shift; my$replo = shift; my$usersince = shift; my@level = qw(anonymous initiate novice acolyte scribe monk friar abbo +t bishop pontiff saint); my@lastnode = sort {$b cmp $a} values %node_cre; print qq~<table border="0" width="100%" cellpadding="0" cellspacing="0 +"> <tr bgcolor="#ffffff"><td><b>User:</b> $xusername (<a href="$pmurl?nod +e_id=$homenode">$homenode</a>)<br> <b>Level:</b> $level - $level[$level] <br></td> <td align='right'><b>User since:</b> $usersince <br> <b>Last here:</b> $lastnode[0] <br></td></tr> <tr><td colspan="2" height="5"><font size="-7">&nbsp;</font></td></tr> <tr bgcolor="#f0f0f0"><td> <table border="0" width="100%" cellpadding="2" cellspacing="0"> <tr align="right"><td>~; my$avg = sprintf ("%3.2f", ($total_rep/$total_nodes)); $avgrep = sprintf ("%d", $avg); $replo = sprintf ("%d", $replo); print qq~Total nodes: $total_nodes </td></tr><tr align=right><td> Total reputation: $total_rep </td></tr><tr align=right><td> Total experience: $xp </td></tr></table></td> <td><table border="0" width="100%" cellpadding="2" cellspacing="0"><tr + align="right"><td> Max reputation: $rephi </td></tr><tr align=right><td> ($avg) Avg reputation: $avgrep </td></tr><tr align=right><td> Min reputation: $replo </td></tr></table></td></tr></table>~; } sub change_sum { # display the xp/rep change summary my($v1,$v2,$v3,$v4,$v5) = @_; my$color = ''; if($v1 < 0){$color = ' bgcolor="#ffbbbb"'} if($v1 > 0){$color = ' bgcolor="#d0d0d0"'} print qq~<tr align="right"><td bgcolor="#ffffff"> $v2</td><td bgcolor="#d0d0d0"> $v3</td><td bgcolor="#d0d0d0"> $v4</td><td$color> $v5</td></tr>~; } sub graph { # calculate and display the graphs my($hm1,$hm2,$hm3,$bdr); if($i{'histmode'}=~/02/){ $bdr = 1 } else { $bdr = 0 } print qq~<p><table border="$bdr" cellpadding="0" cellspacing="0" width +="100%"> <tr><th align="left" colspan="3" valign="top"> <table border="0" cellpadding="0" cellspacing="0" width="100%" bgcolor +="#cfcfcf"> <tr><th align="left">&nbsp;&nbsp; <h2>Number of nodes by reputation <font size="-1"><br>average rep and maximum num highlighted</font></h2 +></th> <td><table align="right" border="0" cellpadding="3" cellspacing="0"><t +r><td>~; if( ($i{'histmode'}=~/01/) or (!$i{'histmode'}) ){ $hm1 = ' checked'; print qq~<b>mode one</b><br><small> bar height = fixed<br> bar width = number of nodes at that rep<br></small></td></tr>~ } if($i{'histmode'}=~/02/){ $hm2 = ' checked'; print qq~<b>mode two</b><br><small> bar height = rep<br> bar width = number of nodes at that rep<br></small></td></tr>~ } if($i{'histmode'}=~/03/){ $hm3 = ' checked'; print qq~<b>mode three</b><br><small> bar height = number of nodes at that rep<br> bar width = rep<br></small></td></tr>~ } print qq~<tr><form method="$form_method"><td align="right" valign="bot +tom"> 1<input type="radio" name="histmode" value="01"$hm1> 2<input type="radio" name="histmode" value="02"$hm2> 3<input type="radio" name="histmode" value="03"$hm3> <input type="hidden" name="n" value="graph"> <input type="submit" value="mode"></td></form></tr></table> </td></tr></table></td></tr>~; my@high = sort {$b <=> $a} values %rep_freq; my@hig = sort {$b <=> $a} keys %rep_freq; my$mult = sprintf "%d", (600/$high[0]); # normalize bar width to scale + (highest num = 600 pixels) my$mul = sprintf "%d", (600/$hig[0]); # normalize bar width to scale +(highest num = 600 pixels) print qq~<tr bgcolor="#b0b0b0"><td><b>$nb rep $nb</td><td><b>$nb num $ +nb</td><td>&nbsp;</td></tr>~; my($ar,$fc,$arf,$fcf) = ''; for(sort {$b <=> $a} keys %rep_freq){ my$w = ($rep_freq{$_}*$mult); my$h = 5; if($i{'histmode'}){ if($i{'histmode'}=~/01/){} if($i{'histmode'}=~/02/){ $h = ($_); if($h == 0){$h = 1} } if($i{'histmode'}=~/03/){ $w = ($_*$mul); $h = $rep_freq{$_} } } if($_ == $avgrep){ # highlight avg rep $ar = 'bgcolor="#880066"'; $fc = '<font color="white">' } else{$ar=''; $fc='';} if($rep_freq{$_} == $high[0]){ # highlight frequency high $arf = 'bgcolor="#880066"'; $fcf = '<font color="white">' } else{$arf=''; $fcf=''} print qq~<tr><td $ar align="right">$fc $_ $nb</td><td $arf align=" +right">$fcf $rep_freq{$_} $nb</td><td>~; print qq~<table border="0" cellpadding="0" cellspacing="0"> <tr><td bgcolor="#880066"><img src="$uri?n=gif" width="$w" height= +"$h" border="0"></td></tr></table> </td></tr>~ } print qq~<tr bgcolor="#b0b0b0"> <td><b>$nb rep $nb</td><td><b>$nb num $nb</td><td>&nbsp;</td></tr></ta +ble><p>~; }

In reply to reputer by epoptai

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Domain Nodelet?
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this?Last hourOther CB clients
    Other Users?
    Others examining the Monastery: (4)
    As of 2024-10-07 21:17 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      The PerlMonks site front end has:





      Results (44 votes). Check out past polls.

      Notices?
      erzuuli‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.