#!/usr/bin/perl use strict; use warnings; use utf8; use TUWF ':html', ':xml'; use POSIX 'strftime'; use Cwd 'abs_path'; our $ROOT; BEGIN { ($ROOT = abs_path $0) =~ s{index\.cgi$}{}; } my @changes = ( [ '2012-08-16', '/ncdc', 'ncdc 1.13 released.' ], [ '2012-07-10', '/ncdc', 'ncdc 1.12 released.' ], [ '2012-05-15', '/ncdc', 'ncdc 1.11 released.' ], [ '2012-05-03', '/ncdc/install', 'Added installation instructions for ncdc.' ], [ '2012-05-03', '/ncdc', 'ncdc 1.10 released.' ], [ '2012-04-10', undef, 'Minor site re-style: ncdu/ncdc/tuwf now have their own menu.' ], [ '2012-03-30', '/dump', 'Updated ncdc-share-report for Go 1' ], [ '2012-03-24', '/ncdu/bug', 'Moved ncdu bug tracker from sourceforge to this site' ], [ '2012-03-17', '/ncdc/bug', 'Wrote a small bug tracker for ncdc' ], [ '2012-03-14', '/ncdc', 'ncdc 1.9 released.' ], [ '2012-02-15', '/doc/commvis', 'Added an article on my new communication system.' ], [ '2012-02-13', '/ncdc', 'ncdc 1.8 released.' ], [ '2012-01-19', '/tuwf', 'TUWF 0.2 released.' ], [ '2012-01-17', undef, 'Complete site redesign.' ], [ '2011-12-30', '/ncdc/', 'ncdc 1.7 released!' ], [ '2011-12-07', '/ncdc/', 'ncdc 1.6 released!' ], [ '2011-11-26', '/doc', 'Added article section and the article on SQLite.' ], [ '2011-11-03', '/ncdu', 'ncdu 1.8 released!' ], [ '2011-11-03', '/ncdc', 'ncdc 1.5 released!' ], [ '2011-10-26', '/ncdc', 'ncdc 1.4 released!' ], [ '2011-10-19', undef, 'PGP-signed all releases of ncdu, ncdc and TUWF.' ], [ '2011-10-14', '/ncdc', 'ncdc 1.3 released!' ], [ '2011-09-25', '/ncdc', 'ncdc 1.1 released - follwed by a 1.2 quickfix.' ], [ '2011-09-16', '/ncdc', 'ncdc 1.0 released!' ], [ '2011-09-15', '/ncdc/scr', 'Added some screenshots for ncdu.' ], [ '2011-09-03', '/ncdc', 'ncdc 0.9 released!' ], [ '2011-08-26', '/ncdc', 'ncdc 0.8 released!' ], [ '2011-08-17', '/ncdc', 'ncdc 0.7 released!' ], [ '2011-08-08', '/ncdc', 'ncdc 0.6 released & user guide updated' ], [ '2011-08-02', '/ncdc', 'ncdc 0.5 released!' ], [ '2011-07-23', '/ncdc', 'ncdc 0.4 released!' ], [ '2011-07-15', '/ncdc', 'ncdc 0.3 released!' ], [ '2011-06-27', '/ncdc', 'ncdc 0.2 released!' ], [ '2011-06-20', '/ncdc', 'ncdc 0.1 released! And wrote a user guide for it.' ], [ '2011-06-11', '/dump/nccolour', 'Added NCurses colour experiment' ], [ '2011-06-03', '/ncdc', 'Added my latest project: ncdc' ], [ '2011-02-07', '/tuwf', 'TUWF 0.1 released and now also available on CPAN' ], [ '2011-01-27', '/tuwf', 'Documented and uploaded one of my older projects: TUWF' ], [ '2011-01-09', '/dump', 'Added my json.mll OCaml library to code dump' ], [ '2010-08-13', '/ncdu', 'ncdu 1.7 released!' ], [ '2009-12-22', '/dump', 'Added vinfo.c script to code dump' ], [ '2009-10-23', '/ncdu', 'ncdu 1.6 released!' ], [ '2009-09-21', undef, 'Tiny CSS fix to make this site look good in certain configurations.' ], [ '2009-05-02', '/ncdu', 'ncdu 1.5 released!' ], [ '2009-04-30', undef, 'Site redesign and reorganisation.' ], ); TUWF::register( qr{} => sub { podpage(shift, 'home', '', '', "Yorhel's Projects") }, qr{ncdu} => sub { podpage(shift, 'ncdu', 'ncdu', '', 'NCurses Disk Usage') }, qr{ncdu/man} => sub { podpage(shift, 'ncdu-man', 'ncdu', 'man', 'Ncdu Manual') }, qr{ncdu/changes} => sub { changelog(shift, 'ncdu-changelog', 'ncdu', 'ncdu', 'changes', 'Ncdu Changelog') }, qr{ncdu/scr} => sub { podpage(shift, 'ncdu-scr', 'ncdu', 'scr', 'Ncdu Screenshots') }, qr{ncdc} => sub { podpage(shift, 'ncdc', 'ncdc', '', 'NCurses Direct Connect') }, qr{ncdc/faq} => sub { podpage(shift, 'ncdc-faq', 'ncdc', 'faq', 'Ncdc Q&A', 1) }, qr{ncdc/scr} => sub { podpage(shift, 'ncdc-scr', 'ncdc', 'scr', 'Ncdc Screenshots') }, qr{ncdc/man} => sub { podpage(shift, 'ncdc-man', 'ncdc', 'man', 'Ncdc Manual', 1) }, qr{ncdc/install} => sub { podpage(shift, 'ncdc-install', 'ncdc', 'install', 'Ncdc Installation Instructions', 1) }, qr{ncdc/changes} => sub { changelog(shift, 'ncdc-changelog', 'ncdc', 'ncdc', 'changes', 'Ncdc Changelog') }, qr{tuwf} => sub { podpage(shift, 'tuwf', 'tuwf', '', 'The Ultimate Website Framework') }, qr{tuwf/man(?:/(db|misc|request|response|xml))?} => \&tuwfmanual, qr{tuwf/changes} => sub { changelog(shift, 'tuwf-changelog', 'TUWF', 'tuwf', 'changes', 'TUWF Changelog') }, qr{doc} => sub { podpage(shift, 'doc', 'doc', '', 'Articles') }, qr{doc/sqlaccess} => sub { podpage(shift, 'sqlaccess', 'doc', '', 'Multi-threaded Access to an SQLite3 Database', 1) }, qr{doc/commvis} => sub { podpage(shift, 'doc-commvis', 'doc', '', 'A Distributed Communication System for Modular Applications', 1) }, qr{dump} => sub { podpage(shift, 'dump', 'dump', '', 'Code dump') }, qr{demo} => sub { podpage(shift, 'dump-demo', 'dump', 'demo', 'Demos') }, qr{dump/awshrink} => sub { podpage(shift, 'dump-awshrink', 'dump', 'awshrink', 'AWStats Data File Shrinker') }, qr{dump/grenamr} => sub { podpage(shift, 'dump-grenamr', 'dump', 'grenamr', 'GTK+ Mass File Renamer') }, qr{dump/nccolour} => sub { podpage(shift, 'dump-nccolour', 'dump', 'nccolour', 'Colours in NCurses') }, qr{feed\.atom} => \&atom, qr{(ncdc|ncdu)/bug} => \&bug_list, qr{(ncdc|ncdu)/bug/post} => \&bug_post, qr{(ncdc|ncdu)/bug/new} => \&bug_new, qr{(ncdc|ncdu)/bug/([1-9][0-9]*)} => \&bug_item, ); TUWF::set( logfile => '/home/yorhel/tuwf.log', error_404_handler => \¬found, mail_from => 'Yorhels Bug Tracker ', # this is a fairly static site, allow some aggressive caching pre_request_handler => sub { $_[0]->resHeader('Cache-Control', 's-max-age=86400, max-age=3600'); 1; }, cookie_defaults => { domain => 'dev.yorhel.nl', path => '/' }, ); TUWF::run(); sub podpage { my($s, $f, $p, $se, $t, $toc) = @_; $s->htmlHeader(title => $t, page => $p, sec => $se); $s->htmlPOD($f, $toc); $s->htmlFooter; } sub changelog { my($s, $f, $pr, $p, $se, $t) = @_; $s->htmlHeader(title => $t, page => $p, sec => $se); open my $F, '<', "$ROOT/dat/$f" or die $!; ul; for my $v (split /\n\n/, join '', <$F>) { $v =~ s/^([0-9]+\.[0-9]+)\s+-\s+([0-9]{4}-[0-9]{2}-[0-9]{2})//; li style => 'list-style-type: none; margin: 0'; b $1; txt " - $2 - "; lit $s->genDLLink("$pr-$1.tar.gz"); br; ul; for (split(/\r?\n\s+-\s+/, $v)) { s/[\r\n\s]{2,50}/ /; li $_ if $_; } end; br; end; } end; close $F; $s->htmlFooter; } sub tuwfmanual { my $s = shift; my $man = shift || ''; my %mod = (qw|db DB xml XML|); my $mod = 'TUWF'; $mod .= '/'.($mod{$man} || ucfirst $man) if $man; (my $pm = $mod) =~ s/\//::/; $s->htmlHeader(title => $pm.' Documentation', page => 'tuwf', sec => 'man', sec2 => $man); (my $f = $INC{"$mod.pm"}) =~ s/\.pm$/.pod/; $s->htmlPOD($f, 1); $s->htmlFooter; } sub atom { my $s = shift; my $t = (stat("$ROOT/index.cgi"))[9]; $s->resHeader('Last-Modified' => strftime '%a, %d %b %Y %H:%M:%S GMT', gmtime $t); $s->resHeader('Content-Type' => 'application/atom+xml'); xml; tag feed => xmlns => 'http://www.w3.org/2005/Atom', 'xml:lang' => 'en', 'xml:base' => 'http://dev.yorhel.nl/'; tag title => "Yorhel's Projects"; tag updated => strftime('%Y-%m-%dT%H:%M:%SZ', gmtime $t); tag id => "http://dev.yorhel.nl/feed.atom"; tag link => rel => 'self', type => 'application/atom+xml', href => "http://dev.yorhel.nl/feed.atom", undef; tag link => rel => 'alternate', type => 'text/html', href => 'http://dev.yorhel.nl/', undef; for(@changes) { tag 'entry'; tag id => 'http://dev.yorhel.nl'.($_->[1]||'/').'#'.$_->[0]; tag title => $_->[2]; tag updated => $_->[0].'T12:00:00Z'; tag published => $_->[0].'T12:00:00Z'; tag 'author'; tag name => 'Yoran Heling'; tag uri => 'http://dev.yorhel.nl/'; tag email => 'projects@yorhel.nl'; end; tag link => rel => 'alternate', type => 'text/html', href => 'http://dev.yorhel.nl'.($_->[1]||'/'), undef; end 'entry'; } end 'feed'; } sub notfound { my $s = shift; my $u = lc $s->reqPath; ($_->[0] eq $u || $_->[0] eq "$u/") && return $s->resRedirect($_->[1], 'perm') for ( [ 'bluecubes', '/demo' ], [ 'ncdc/guide', '/ncdc/man' ], [ 'dump', '/dump' ], [ 'dump/index2', '/dump' ], [ 'dump/pmdc2-parse', '/dump' ], [ 'dump/cbbcode', '/dump' ], [ 'dump/cechoserv', '/dump' ], [ 'dump/cyapong', '/dump' ], [ 'dump/awshrink', '/dump/awshrink' ], [ 'dump/grenamr', '/dump/grenamr' ], ); return $s->resRedirect("/$u", 'perm') if $u =~ s/\/$//; return $s->resRedirect("/$1/bug$2", 'perm') if $u =~ /^(ncd[uc])\/issue(.*)$/; $s->resStatus(404); $s->htmlHeader(title => '404', page => '404'); txt 'Sorry, there is no page at this URI. Try one of the links from the menu to find the page you are looking for.'; $s->htmlFooter; } # Bug tracker sub _bug_init { require "$ROOT/Bug.pm"; my($s, $p) = @_; $s->resHeader('Cache-Control', 'no-cache'); $s->_load_module('TUWF::DB'); $s->{_TUWF}{db_login} = [ undef, undef, undef ]; $s->dbInit; return TUWF::Bug->new(prefix => $p.'_', admins => [ $ENV{ISSUE_CODE} ]); } sub bug_list { my($s, $p) = @_; my $is = _bug_init(@_); $s->htmlHeader(title => "\u$p Bug tracker", page => $p, sec => 'bug'); br; a href => "/$p/bug/new", 'Report new bug'; br; br; $is->htmlListing((scalar $is->dbListing()), sub { "/$p/bug/".shift }); br; a href => "/$p/bug/new", 'Report new bug'; br; br; $s->htmlFooter; } sub bug_new { my($s, $p) = @_; my $is = _bug_init(@_); $s->htmlHeader(title => "\u$p: Report new bug", page => $p, sec => 'bug'); br; a href => "/$p/bug", 'Back to the bug index'; br; br; $is->htmlForm(undef, "/$p/bug/post"); $s->htmlFooter; } sub bug_post { my($s, $p) = @_; return $s->resNotFound if $s->reqMethod() ne 'POST'; my $is = _bug_init($s, $p); my($f, $l) = $is->handleForm(sub { "/$p/bug/".shift }); if($f->{_err}) { $s->htmlHeader(title => 'Error creating message', page => $p, sec => 'bug'); p 'There was an error in the form. Please use the \'back\' button of your browser to go back to the form (hopefully) without losing your message. There was an error in the following fields: '.join(', ', map {(my$f=$_->[0])=~s/bug_// ;"\u$f"} @{$f->{_err}}).'.'; return $s->htmlFooter; } # Experimental: announce this report to the ncdc hub, through the globster bot my $sock = '/tmp/globster.sock'; if(-e $sock) { my $msg = "Bug activity for $p: $l->{summary} -> http://dev.yorhel.nl/$p/bug/$l->{issue}"; require AnyEvent; require AnyEvent::Handle; require AnyEvent::Socket; require Tanja; my $done = AnyEvent->condvar; my $node = Tanja::Node->new(); AnyEvent::Socket::tcp_connect('unix/', $sock, sub { my $fh = shift; warn $! && $done->send if !$fh; my $lnk; $lnk = $fh && $node->link(handle => AnyEvent::Handle->new(fh => $fh), sync => 0, on_error => sub { $_[0]&&warn$_[0]; $done->send }, on_ready => sub { $node->send([hub=>ncdc=>chat=>undef,0,$msg]); $lnk->close; }, ); }); $done->recv; } } sub bug_item { my($s, $p, $i) = @_; my $is = _bug_init($s, $p); my $item = $is->dbItem($i); return $s->resNotFound if !@$item; my $last = $item->[$#$item]; $s->htmlHeader(title => "\u$p: $last->{summary}", page => $p, sec => 'bug'); br; a href => "/$p/bug", 'Back to the bug index'; br; br; $is->htmlItem($item); $is->htmlForm($last, "/$p/bug/post") if !$last->{closed}; br; a href => "/$p/bug", 'Back to the bug index'; br; br; $s->htmlFooter; } package TUWF::Object; use TUWF ':html'; # Accepts some special formatting codes: # [dllink $file $title] # [img $class $file $alt] # [html]..É # [yh-changes] sub htmlPOD { my($s, $file, $toc) = @_; require Pod::Simple::HTML; # The usual output escaping function is terribly stupid { no warnings 'redefine', 'once'; *Pod::Simple::HTML::esc = sub { return map TUWF::XML::html_escape($_), @_ if wantarray; return TUWF::XML::html_escape($_[0]) if defined wantarray; $_ = TUWF::XML::html_escape($_) for(@_); return @_; }; } my $p = Pod::Simple::HTML->new(); my $html = ''; $p->html_header_before_title(''); $p->html_footer(''); $p->output_string(\$html); $p->{podhtml_LOT} = { 'TUWF' => '/tuwf/man', 'TUWF::DB' => '/tuwf/man/db', 'TUWF::Misc' => '/tuwf/man/misc', 'TUWF::Request' => '/tuwf/man/request', 'TUWF::Response' => '/tuwf/man/response', 'TUWF::XML' => '/tuwf/man/xml', }; open(my $F, '<:utf8', $file =~ /^\// ? $file : "$ROOT/dat/$file") or die $!; $p->parse_file($F); close $F; lit $p->index_as_html() if $toc; $html =~ s/\[dllink ([^ ]+)(?: ([^>]+))?\]/$s->genDLLink($1, $2)/eg; $html =~ s/\[img ([^ ]+) ([^ ]+) ([^\]]*)\]/$3/g; $html =~ s{\[html\](.*)É}{(my $h = $1) =~ s/\>/>/g; $h =~ s/\</genChanges()/e; lit $html; } sub genDLLink { my($s, $f, $m) = @_; return sprintf '%s' .'pgp-sha1-md5', $f, $f||$m; } # Generate the changelog HTML for this website sub genChanges { return join "\n", map { "$_->[0] " .($_->[1]?qq{}:'') .TUWF::XML::html_escape($_->[2]) .($_->[1]?'':'') .'
'; } @changes; } sub htmlHeader { my $s = shift; my %o = ( spec => { map +($_,1), qw|ncdu ncdc tuwf| }, page => '', sec => '', sec2 => '', @_ ); html; head; Link rel => 'stylesheet', href => '/style.css', type => 'text/css', media => 'all'; Link rel => 'alternate', type => 'application/atom+xml', href => '/feed.atom', title => 'Site updates'; title $o{title}; end; body; div id => 'body'; div id => 'uglyhack', ' '; div id => 'left'; $s->htmlMenu(%o); div class => 'notes'; txt 'Yoran Heling'; br; a href => 'mailto:projects@yorhel.nl', 'projects@yorhel.nl'; br; a href => 'http://yorhel.nl', 'yh'; txt ' - '; a href => 'http://g.blicky.net', 'git'; txt ' - '; a href => 'http://github.com/yorhel', 'github'; txt ' - '; a href => 'http://pgp.mit.edu:11371/pks/lookup?search=0x8c2739fa', 'pgp'; br;br; lit q|
|; end; end 'div'; div id => 'main'; h1 class => 'title', $o{title}; } sub htmlFooter { end 'div'; # main div id => 'footer'; p 'end-of-file'; end; end 'div'; # body end 'body'; end 'html'; } sub htmlMenu { my($s, %o) = @_; h1 class => 'title', "~ \u$o{page} ~" if $o{spec}{$o{page}}; my $m = sub { li; my $s = $_[0] =~ m{^/([^/]+)} && $o{spec}{$1} && $o{page} ne $1; a href => $_[0], $s?(class=>'special'):$_[2]?(class=>'menusel'):(), $_[1]; if($_[3]) { ul; $_[3]->(); end; } end; }; ul; if($o{page} eq 'ncdu') { $m->('/ncdu', 'Info', !$o{sec}); $m->('/ncdu/man', 'Manual', $o{sec} eq 'man'); $m->('/ncdu/changes', 'Changelog', $o{sec} eq 'changes'); $m->('/ncdu/scr', 'Screenshots', $o{sec} eq 'scr'); $m->('/ncdu/bug', 'Bug tracker', $o{sec} eq 'bug'); } elsif($o{page} eq 'ncdc') { $m->('/ncdc', 'Info', !$o{sec}); $m->('/ncdc/install', 'Installation',$o{sec} eq 'install'); $m->('/ncdc/faq', 'Q&A', $o{sec} eq 'faq'); $m->('/ncdc/man', 'Manual', $o{sec} eq 'man'); $m->('/ncdc/changes', 'Changelog', $o{sec} eq 'changes'); $m->('/ncdc/scr', 'Screenshots', $o{sec} eq 'scr'); $m->('/ncdc/bug', 'Bug tracker', $o{sec} eq 'bug'); } elsif($o{page} eq 'tuwf') { $m->('/tuwf', 'Info', !$o{sec}); $m->('/tuwf/man', 'Manual', $o{sec} eq 'man', sub { $m->('/tuwf/man', 'Main', $o{sec} eq 'man' && !$o{sec2}); $m->('/tuwf/man/db', '::DB', $o{sec} eq 'man' && $o{sec2} eq 'db'); $m->('/tuwf/man/misc', '::Misc', $o{sec} eq 'man' && $o{sec2} eq 'misc'); $m->('/tuwf/man/request', '::Request', $o{sec} eq 'man' && $o{sec2} eq 'request'); $m->('/tuwf/man/response', '::Response', $o{sec} eq 'man' && $o{sec2} eq 'response'); $m->('/tuwf/man/xml', '::XML', $o{sec} eq 'man' && $o{sec2} eq 'xml'); }); $m->('/tuwf/changes', 'Changelog', $o{sec} eq 'changes'); } else { $m->('/', 'Home', !$o{page}); $m->('/ncdu', 'Ncdu '); $m->('/ncdc', 'Ncdc '); $m->('/tuwf', 'Tuwf '); $m->('/doc', 'Articles', $o{page} eq 'doc'); $m->('/dump', 'Code dump', $o{page} eq 'dump', sub { $m->('/dump', 'Misc.', $o{page} eq 'dump' && !$o{sec}); $m->('/demo', 'Demos', $o{page} eq 'dump' && $o{sec} eq 'demo'); $m->('/dump/awshrink','AWShrink', $o{page} eq 'dump' && $o{sec} eq 'awshrink'); $m->('/dump/grenamr', 'Grenamr', $o{page} eq 'dump' && $o{sec} eq 'grenamr'); $m->('/dump/nccolour','NC-Colour', $o{page} eq 'dump' && $o{sec} eq 'nccolour'); }); } if($o{spec}{$o{page}}) { li; a href => '/', class => 'small special', 'Projects home '; end; } end; }