#!perl -w # # xNN is a CGI newest nodes client that sorts nodes by date, author, category, 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 nodes 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~Download failed! Return~; 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 mode, 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 "That took %.2F CPU seconds.", $end - $start; my$prnt = qq~

$sprnt top xNN by epoptai
~; 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 latin1 $whom{$who->{'node_id'}} = $who->{'content'} } } if(defined @{$data->{'NODE'}}){ for my $new(@{$data->{'NODE'}}){ $new->{'content'} = encode($new->{'content'}); # UTF8 to latin1 $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_node'}; } 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{$root2}->{'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~xNN  ~; } $prnt .= qq~

~; $prnt .= '' if -e $undo; $prnt .= qq~ ~; 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~~; } $prnt .= qq~
Total new nodes $total
~; if($bit && $bit eq 'ca'){ $prnt .= qq~$types{$_} ~; } else{ $prnt .= qq~$types{$_} ~ } $prnt .= qq~ $nodetypes{$_}
Show nodes created within the past days
categorized
chronological
threaded
by author

~; print $prnt; $done++ } sub threaded { my$prnt = ''; @cache = sort {$b <=> $a} keys %nodes; $prnt .= print_nodes(); # thread the nodes $prnt .= qq~~; for(@cache){ # replies to old nodes unless( ($nodes{$_}->{'nodetype'} eq 'user') || ($nodes{$_}->{'parent'} == 0) ){ unless(exists($roots{$nodes{$_}->{'parent'}})){ $prnt .= qq~~ } } } $prnt .= qq~
Replies to older nodes
parenttitleauthordate
$nodes{$_}->{'parent'} $nodes{$_}->{'content'} $whom{$nodes{$_}->{'author'}} $nodes{$_}->{'created'}
~; for(@cache){ # users if($nodes{$_}->{'nodetype'} eq 'user'){ $prnt .= qq~~; } } $prnt .= '
Users
$nodes{$_}->{'content'} $nodes{$_}->{'created'}
'; 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 = ''; $b2 = ''; } $prnt .= '

'; } else{ $prnt .= ''} } } return $prnt } sub cron { # chronological or by author my$bit = pop; # by author if set my$prnt = qq~~; for($bit ? (sort { lc($whom{$nodes{$a}->{'author'}}) cmp lc($whom{$nodes{$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 = 'root' } if(($nodes{$_}->{'nodetype'} ne 'note') && ($nodes{$_}->{'nodetype'} ne 'user')){ $e = " bgcolor='#ffffff'" } $prnt .= qq~~; if($nodes{$_}->{'parent'} == 0){ $prnt .= qq~~ } else{ $prnt .= qq~~ } $prnt .= qq~~; } $prnt .= '

~; if($bit){ $prnt .= 'Sort by Author'} else { $prnt .= 'Chronological
top node newest'} $prnt .= qq~

ParentTitleAuthorCategoryCreated
$f $nodes{$_}->{'parent'} $nodes{$_}->{'content'} $whom{$nodes{$_}->{'author'}} ~; if(exists($stypes{$nodes{$_}->{'nodetype'}})){ # use short version of long nodetypes $prnt .= qq~$stypes{$nodes{$_}->{'nodetype'}}~ } else{ $prnt .= qq~$types{$nodes{$_}->{'nodetype'}}~ } $prnt .= qq~ $nodes{$_}->{'created'}

'; print $prnt } sub types { # by nodetype my@done = sort {$b <=> $a} keys %nodes; my$prnt = qq~~; for my $type (sort { $types{$a} cmp $types{$b} } keys %nodetypes){ unless($type=~/note|user/){ (my$t = $types{$type}) =~ tr/ /+/; $prnt .= qq~~ } for(@done){ if(($nodes{$_}->{'nodetype'} eq $type) && ($type!~/note|user/)){ $prnt .= qq~~; } } } for my $type (sort {$a cmp $b} keys %nodetypes){ if($type eq 'note'){ # notes $prnt .= qq~~ } if($type eq 'user'){ # users $prnt .= qq~~ } for(@done){ # replies if(($nodes{$_}->{'nodetype'} eq $type) && ($type eq 'note')){ $prnt .= qq~~; } } for(@done){ # users if(($nodes{$_}->{'nodetype'} eq $type) && ($type eq 'user')){ $prnt .= qq~~; } } } $prnt .= '

Categorized
top node newest


$types{$type}

$nodes{$_}->{'content'} $whom{$nodes{$_}->{'author'}} $nodes{$_}->{'created'}

$types{$type}

parent 

$types{$type}

$nodes{$_}->{'parent'} $nodes{$_}->{'content'} $whom{$nodes{$_}->{'author'}} $nodes{$_}->{'created'}
$nodes{$_}->{'content'} $nodes{$_}->{'created'}

'; print $prnt } sub fixxml { # append headers to xml nodes so they parse correctly my$xml = shift; my$fix = q{ }; # mirod to the rescue! $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(){ 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 XML::Simple~; exit }