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

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
#!perl -w # # xNN is a CGI newest nodes client that sorts nodes by date, author, c +ategory, and threads. # Displays nodes from n days in the past, or fractions of the current +day. # Saves node data to disk, uses cookies to remember sort mode, and can + undo a refresh. # Requires XML::Simple # # Note: Threaded mode can get dramatically slower as the number of nod +es increases, # so be prepared to wait to thread more than a few days worth (1000+). # # usage: # Make sure the first 3 variables and the #! line are correct and load + in a browser. # First run involves your first download of new nodes so be online. # # coded by epoptai - http://perlmonks.org/index.pl?node=epoptai # Updated: 5.23.2002 use strict; use CGI::Carp 'fatalsToBrowser'; use CGI::Cookie; use CGI qw(param header url); use LWP::Simple 'get'; use Data::Dumper; eval("use XML::Simple 'XMLin'"); # required xml parser $@ && install_xml_simple(); # check the values of these 3 variables my$perlmonks = 'www.perlmonks.org'; # your usual perlmonks domain my$temp = './'; # where to write data and undo files my$trgt = ' target="_self"'; # link target window my@days = qw(0.1 0.5 1 2 3 4 5 6 7); # day values for the select menu, + can customize but max = 8 days my$pmurl = "http://$perlmonks/index.pl"; my$nnxml = "$pmurl?node_id=30175"; # new nodes xml ticker my$method = 'post'; # 'get' may cause a re-refresh when using the back + button after refresh my$done = 0; use vars qw( @kids @cache @sorted %nodes %nodetype %nodetypes %whom %roots $total $lastcheck $data $data1 $b1 $b2 $numdays $nd ); my%types = ( 'bookreview' => 'Book Reviews', 'categorized answer' => 'Categorized Answers', 'categorized question' => 'Categorized Questions', 'CUFP' => 'Cool Uses for Perl', 'modulereview' => 'Reviews', 'monkdiscuss' => 'Perlmonks Discussion', 'note' => 'Reply', 'obfuscated' => 'Obfuscated Code', 'perlcraft' => 'Perl Craft', 'perlmeditation' => 'Meditations', 'perlnews' => 'Perl News', 'perltutorial' => 'Tutorials', 'perlquestion' => 'Seekers of Perl Wisdom', 'poem' => 'Poems', 'review' => 'Reviews', 'snippet' => 'Snippets Section', 'sourcecode' => 'Code Catacombs', 'tutorial' => 'Tutorials', 'user' => 'Users', ); my%stypes = ( 'bookreview' => 'Book', 'categorized answer' => 'Answers', 'categorized question' => 'Questions', 'CUFP' => 'Cool Uses', 'monkdiscuss' => 'Discussion', 'obfuscated' => 'Obfuscated', 'perlquestion' => 'Seekers', 'snippet' => 'Snippets', 'sourcecode' => 'Code', ); my$file = $temp.'xnn.dat'; my$undo = $file.'.undo'; my$uri = url(); my$handle = select(); my%i = map {$_ => param($_)} param; my%cookies = CGI::Cookie->fetch(); my$start = (times)[0]; copy($undo,$file) if (($i{'m'} && $i{'m'} eq 'undo') && -e $undo); if( (($i{'m'}) && ($i{'m'} eq 'refresh')) || (!-e $file) ){ if($i{'numdays'} && $i{'pageloadtime'}){ $numdays = $i{'numdays'}; my$sut = ( $i{'pageloadtime'} - (86400*$numdays) ); $nnxml = $nnxml."&sinceunixtime=$sut"; } my$nn = get "$nnxml"; unless($nn=~/\S/){ print header; print qq~<html>Download failed! <a href="$uri">Return</a>~; exit } $nn = fixxml($nn); $data = XMLin($nn, forcearray => 1); copy($file,$undo) if -e $file; open(DAT,"> $file") or die "$!"; $Data::Dumper::Indent = 0; $Data::Dumper::Varname = 'data'; print DAT Dumper($data); if($i{'numdays'}){ print DAT qq~\$nd = $i{'numdays'};~; } close DAT or die "$!"; } else{ if(eval "require '$file'"){ $data = $data1; $numdays = $nd; } } my($c1,$c2,$c3,$c4,$cookie,$mode) = ('') x 6; if( ($i{'n'}) || ($i{'m'}) || ($cookies{'nn_mode'}) ){ # determine mod +e, set cookies, execute subs unless($i{'n'}){ $mode = $cookies{'nn_mode'}->value if $cookies{'nn_mode'}; } if(($i{'n'} && $i{'n'} eq 'categorized') || $mode eq 'ca'){ if($i{'n'} && $i{'n'} eq 'categorized'){ $cookie = CGI::Cookie->new(-name=>'nn_mode',-value=>'ca',- +expires=>'+1y'); } $c1 = ' checked'; initdat(); stance('ca'); types(); # categorized } if(($i{'n'} && $i{'n'} eq 'chronological') || $mode eq 'ch'){ if($i{'n'} && $i{'n'} eq 'chronological'){ $cookie = CGI::Cookie->new(-name=>'nn_mode',-value=>'ch',- +expires=>'+1y'); } $c2 = ' checked'; initdat(); stance('ch'); cron(); # chronological } if(($i{'n'} && $i{'n'} eq 'threaded') || $mode eq 'th'){ if($i{'n'} && $i{'n'} eq 'threaded'){ $cookie = CGI::Cookie->new(-name=>'nn_mode',-value=>'th',- +expires=>'+1y'); } $c3 = ' checked'; initdat('th'); stance('th'); threaded(); # threaded } if(($i{'n'} && $i{'n'} eq 'byauthor') || $mode eq 'au'){ if($i{'n'} && $i{'n'} eq 'byauthor'){ $cookie = CGI::Cookie->new(-name=>'nn_mode',-value=>'au',- +expires=>'+1y'); } $c4 = ' checked'; initdat(); stance('au'); cron('au'); # by author } } else{ $c2 = ' checked'; initdat(); stance('ch'); } my$end = (times)[0]; my$sprnt = sprintf "<font size='-1'><b>That took %.2F CPU seconds.</b> +</font>", $end - $start; my$prnt = qq~<p><table width=100% border=1 cellpadding=2 cellspacing= +0 bgcolor="#aaaaaa"><tr><td>$sprnt</td> <td align=center><a href="#top">top</a></td><td align=right><font size +="-1"><i> <a href="$pmurl?node=xNN">xNN</a> by <a href="$pmurl?node=epoptai">epo +ptai</a></i></font> </td></tr></table></body></html>~; print $prnt; exit; sub initdat { my$threaded = pop; if(defined @{$data->{'INFO'}}){ for my $when(@{$data->{'INFO'}}){ $lastcheck = $when->{'lastchecked'}; if($lastcheck =~ /^(....)(..)(..)(..)(..)(..)$/){ $lastcheck = "$4:$5:$6 on $2/$3" } } } if(defined @{$data->{'AUTHOR'}}){ for my $who(@{$data->{'AUTHOR'}}){ $who->{'content'} = encode($who->{'content'}); # UTF8 to latin +1 $whom{$who->{'node_id'}} = $who->{'content'} } } if(defined @{$data->{'NODE'}}){ for my $new(@{$data->{'NODE'}}){ $new->{'content'} = encode($new->{'content'}); # UTF8 to l +atin1 $new->{'author_user'} = encode($new->{'author_user'}); # UTF8 +to latin1 $nodes{$new->{'node_id'}}->{'content'} = $new->{'content'}; $nodes{$new->{'node_id'}}->{'nodetype'} = $new->{'nodetype'}; $nodes{$new->{'node_id'}}->{'author'} = $new->{'author_user' +}; $nodes{$new->{'node_id'}}->{'created'} = $new->{'createtime'} +; if(exists($new->{'parent_node'})){ $nodes{$new->{'node_id'}}->{'parent'} = $new->{'parent_nod +e'}; } else{ $nodes{$new->{'node_id'}}->{'parent'} = 0; } if($threaded){ $nodes{$new->{'node_id'}}->{'kids'} = [@kids]; # empty for + now } $nodetype{$new->{'node_id'}} = $new->{'nodetype'}; # hash for +summary and categorized view } } for(values %nodetype){$nodetypes{$_}++; $total++} my@done = sort {$a <=> $b} keys %nodes; for my $root1 (@done){ if($threaded){ for my $root2 (@done){ if(($nodes{$root2}->{'parent'}) && ($root1 == $nodes{$root +2}->{'parent'})){ push @{$nodes{$root1}->{'kids'}}, $root2; # populate @ +kids } } if($nodes{$root1}->{'nodetype'} ne 'user'){ $roots{$root1} = $root1; } } if($nodes{$root1}->{'created'}=~/^(....)(..)(..)(..)(..)(..)$/){ $nodes{$root1}->{'created'} = "$4:$5:$6 $2/$3" } } } sub stance { # menu and summary my($bit,$prnt) = pop; unless($done > 0){ @sorted = sort {$types{$a} cmp $types{$b}} keys %nodetypes; if($cookie){ print header(-cookie=>[$cookie]) } else{ print header } $prnt .= qq~<html><head><title>xNN</title> <style><!-- td{ font-family:arial;font-size:80%; } --></style></he +ad><body><a name="top">&nbsp;</a>~; } $prnt .= qq~<form method="$method"> <table border="1" cellpadding="8" cellspacing="0" width="100%" bgcolor +="#aaaaaa"> <tr><td valign="top"> ~; $prnt .= '<input type="submit" name="m" value="undo">' if -e $undo; $prnt .= qq~</td><td rowspan="3" align="right"> <table border="1" cellpadding="3" cellspacing="0"> <tr><td align="right"> <b>Total new nodes</b> </td><td> $total </td></ +tr>~; for(@sorted){ my$e = ''; if($bit && ($bit eq 'ch' || 'au')){ $e = " bgcolor='#999999'" if $_ eq 'user'; $e = " bgcolor='#ffffff'" if $_ ne 'user' && $_ ne 'note'; } $prnt .= qq~<tr$e><td>~; if($bit && $bit eq 'ca'){ $prnt .= qq~<a href="#$_">$types{$_}</a> ~; } else{ $prnt .= qq~$types{$_} ~ } $prnt .= qq~</td><td> $nodetypes{$_} </td></tr>~; } $prnt .= qq~</table></td></tr> <tr><form method="$method"><td> <INPUT TYPE="hidden" name="pageloadtime" value="$^T"> Show nodes created within the past <SELECT NAME="numdays">~; for(@days){ $prnt .= qq~<OPTION VALUE="$_"~; if($numdays && $numdays eq $_){ $prnt .= ' selected'; } $prnt .= qq~>$_~; } $prnt .= qq~</SELECT> days <input type="submit" name="m" value="refresh"></td></form></tr> <tr><form method="$method"><td> <input type="radio" name="n" value="categorized"$c1> categorized<br> <input type="radio" name="n" value="chronological"$c2> chronological<b +r> <input type="radio" name="n" value="threaded"$c3> threaded<br> <input type="radio" name="n" value="byauthor"$c4> by author<br> <input type="submit" value="sort"> </td></form></tr></table><p>~; print $prnt; $done++ } sub threaded { my$prnt = '<font size="-1">'; @cache = sort {$b <=> $a} keys %nodes; $prnt .= print_nodes(); # thread the nodes $prnt .= qq~<table border="1" cellpadding="3" cellspacing="0" width="1 +00%"> <tr><th colspan="4" align="left">Replies to older nodes</td></tr> <tr><td>parent</td><td>title</td><td>author</td><td>date</td></tr>~; for(@cache){ # replies to old nodes unless( ($nodes{$_}->{'nodetype'} eq 'user') || ($nodes{$_}->{'par +ent'} == 0) ){ unless(exists($roots{$nodes{$_}->{'parent'}})){ $prnt .= qq~<tr><td><a href="$pmurl?node_id=$nodes{$_}->{' +parent'}"$trgt>$nodes{$_}->{'parent'}</a></td> <td><a href="$pmurl?node_id=$_"$trgt>$nodes{$_}->{'content +'}</a></td> <td><a href="$pmurl?node_id=$nodes{$_}->{'author'}"$trgt>$ +whom{$nodes{$_}->{'author'}}</a></td> <td>$nodes{$_}->{'created'}</td></tr>~ } } } $prnt .= qq~</table><table border="1" cellpadding="3" cellspacing="0" +width="100%"> <tr><th colspan="2" align="left">Users</td></tr>~; for(@cache){ # users if($nodes{$_}->{'nodetype'} eq 'user'){ $prnt .= qq~<tr><td><a href="$pmurl?node_id=$_"$trgt>$nodes{$_ +}->{'content'}</a></td> <td>$nodes{$_}->{'created'}</td></tr>~; } } $prnt .= '</table>'; print $prnt } sub print_nodes { # recursive sub for threaded my@kids = @_; my$prnt; for( (@kids) ? (@kids) : (@cache) ){ ($b1,$b2) = ('') x 2; if( (@kids) ? (@kids) : ((!$nodes{$_}->{'parent'}) && ($nodes{$_}- +>{'nodetype'} ne 'user')) ){ unless(@kids){ $b1 = '<font size="3"><b>'; $b2 = '</b></font>'; } $prnt .= '<ul>'; unless(@kids){ $prnt .= qq~<font size="-1">$types{$nodes{$_}->{'nodetype' +}} ($nodes{$_}->{'created'})</font><br>~; } $prnt .= qq~<li>$b1 <a href="$pmurl?node_id=$_"$trgt>$nodes{$_ +}->{'content'}</a> $b2 by <a href="$pmurl?node_id=$nodes{$_}->{'author'}"$trgt>$whom{ +$nodes{$_}->{'author'}}</a><br>~; if(@{$nodes{$_}->{'kids'}}){ # if this node has children $prnt .= print_nodes(@{$nodes{$_}->{'kids'}}); # recurse $prnt .= '</ul>'; } else{ $prnt .= '</ul>'} } } return $prnt } sub cron { # chronological or by author my$bit = pop; # by author if set my$prnt = qq~<table border="1" cellspacing="0" cellpadding="3" width=" +100%"> <tr align="left"><th colspan="5"><h2>~; if($bit){ $prnt .= 'Sort by Author'} else { $prnt .= 'Chronological<br +><font size="-1">top node newest</font>'} $prnt .= qq~</h2></th></tr><tr align="left"> <td><b>Parent</td><td><b>Title</td><td><b>Author</td><td><b>Category</ +td><td><b>Created</td></tr>~; for($bit ? (sort { lc($whom{$nodes{$a}->{'author'}}) cmp lc($whom{$nod +es{$b}->{'author'}}) } keys %nodes) : (sort {$b <=> $a} keys %nodes)) +{ my($e,$f) = ('') x 2; if($nodes{$_}->{'nodetype'} eq 'user'){ $e = " bgcolor='#999999'"; $f = 'user' } else{ $f = '<b>root</b>' } if(($nodes{$_}->{'nodetype'} ne 'note') && ($nodes{$_}->{'nodetype +'} ne 'user')){ $e = " bgcolor='#ffffff'" } $prnt .= qq~<tr$e>~; if($nodes{$_}->{'parent'} == 0){ $prnt .= qq~<td> <font size="-2">$f</font> </td>~ } else{ $prnt .= qq~<td> <a href="$pmurl?node_id=$nodes{$_}->{'parent' +}"$trgt>$nodes{$_}->{'parent'}</a> </td>~ } $prnt .= qq~<td> <a href="$pmurl?node_id=$_"$trgt>$nodes{$_}->{'co +ntent'}</a> </td> <td> <a href="$pmurl?node_id=$nodes{$_}->{'author'}"$trgt>$whom{$n +odes{$_}->{'author'}}</a> </td> <td> ~; if(exists($stypes{$nodes{$_}->{'nodetype'}})){ # use short version + of long nodetypes $prnt .= qq~$stypes{$nodes{$_}->{'nodetype'}}~ } else{ $prnt .= qq~$types{$nodes{$_}->{'nodetype'}}~ } $prnt .= qq~</td><td> $nodes{$_}->{'created'} </td></tr>~; } $prnt .= '</table><p>'; print $prnt } sub types { # by nodetype my@done = sort {$b <=> $a} keys %nodes; my$prnt = qq~<table border="1" cellspacing="0" cellpadding="3" width=" +100%"> <tr align="left"><th colspan="4"><h2><a name="cats">Categorized</a><br +> <font size="-1">top node newest</font></h2></th></tr>~; for my $type (sort { $types{$a} cmp $types{$b} } keys %nodetypes){ unless($type=~/note|user/){ (my$t = $types{$type}) =~ tr/ /+/; $prnt .= qq~<tr><th align="left" colspan="4"><br> <h3><a name="$type" href="$pmurl?node=$t"$trgt>$types{$type}</ +a></td></tr>~ } for(@done){ if(($nodes{$_}->{'nodetype'} eq $type) && ($type!~/note|user/) +){ $prnt .= qq~<tr> <td colspan="2"> <a href="$pmurl?node_id=$_"$trgt>$nodes{$ +_}->{'content'}</a> </td> <td> <a href="$pmurl?node_id=$nodes{$_}->{'author'}"$trgt> +$whom{$nodes{$_}->{'author'}}</a> </td> <td> $nodes{$_}->{'created'} </td></tr>~; } } } for my $type (sort {$a cmp $b} keys %nodetypes){ if($type eq 'note'){ # notes $prnt .= qq~<tr><th align="left" colspan="4"><br> <h3><a name="$type">$types{$type}</a></td></tr> <tr><td align="left"><b>parent</td><td colspan="3">&nbsp;</td> +</tr>~ } if($type eq 'user'){ # users $prnt .= qq~<tr><th align="left" colspan="4"><br> <h3><a name="$type">$types{$type}</a></td></tr>~ } for(@done){ # replies if(($nodes{$_}->{'nodetype'} eq $type) && ($type eq 'note')){ $prnt .= qq~<tr> <td> <a href="$pmurl?node_id=$nodes{$_}->{'parent'}"$trgt> +$nodes{$_}->{'parent'}</a> </td> <td> <a href="$pmurl?node_id=$_"$trgt>$nodes{$_}->{'conten +t'}</a> </td> <td> <a href="$pmurl?node_id=$nodes{$_}->{'author'}"$trgt> +$whom{$nodes{$_}->{'author'}}</a> </td> <td> $nodes{$_}->{'created'} </td> </tr>~; } } for(@done){ # users if(($nodes{$_}->{'nodetype'} eq $type) && ($type eq 'user')){ $prnt .= qq~<tr> <td colspan="3"> <a href="$pmurl?node_id=$_"$trgt>$nodes{$ +_}->{'content'}</a> </td> <td> $nodes{$_}->{'created'} </td> </tr>~; } } } $prnt .= '</td></tr></table><p>'; print $prnt } sub fixxml { # append headers to xml nodes so they parse correctly my$xml = shift; my$fix = q{<?xml version="1.0" encoding="ISO-8859-1"?> <!DOCTYPE CHATTER SYSTEM "dummy.dtd"[]>}; # mirod to the re +scue! $xml = $fix.$xml; $xml =~ s/[\r\n\t]//g; # jcwren, strip to eliminate problems matching +after parsing return $xml; # to the xml parser } sub encode { # UTF-8 to latin1 regex from XML::TiePYX (thanks to mirod) my($text) = @_; $text =~ s{([\xc0-\xc3])(.)}{ my $hi = ord($1); my $lo = ord($2); chr((($hi & 0x03) <<6) | ($lo & 0x3F)) }ge; return $text; } sub copy { # simple file copy if(-e $_[0]){ open(OLD,"< $_[0]") or die "$!"; } else{ print header; 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 install_xml_simple { # link to dist on cpan print header; print qq~Install <a href='http://search.cpan.org/search?dist=XML-Simple'>XML::Simple</a +>~; exit }

In reply to xNN 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!
  • 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, 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, 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
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others taking refuge in the Monastery: (18)
    As of 2015-07-07 17:52 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (93 votes), past polls