Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

comment on

( [id://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":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
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-03-29 09:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found