#!/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-03-24', '/ncdu/issue', 'Moved issue tracker from sourceforge to this site' ], [ '2012-03-17', '/ncdc/issue', 'Wrote a small issue 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/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)/issue} => \&issue_list, qr{(ncdc|ncdu)/issue/post} => \&issue_post, qr{(ncdc|ncdu)/issue/new} => \&issue_new, qr{(ncdc|ncdu)/issue/([1-9][0-9]*)} => \&issue_item, ); TUWF::set( logfile => '/www/err.log', error_404_handler => \¬found, mail_from => 'Yorhel\'s issue 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; }, ); 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/\/$//; $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; } # Issue handling sub _issue_init { require "$ROOT/Issue.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::Issue->new(prefix => $p.'_', admins => [ $ENV{ISSUE_CODE} ]); } sub issue_list { my($s, $p) = @_; my $is = _issue_init(@_); $s->htmlHeader(title => "\u$p Issue tracker", page => $p, sec => 'issue'); br; a href => "/$p/issue/new", 'Report new issue'; br; br; $is->htmlListing((scalar $is->dbListing()), sub { "/$p/issue/".shift }); br; a href => "/$p/issue/new", 'Report new issue'; br; br; $s->htmlFooter; } sub issue_new { my($s, $p) = @_; my $is = _issue_init(@_); $s->htmlHeader(title => "\u$p: Report new issue", page => $p, sec => 'issue'); br; a href => "/$p/issue", 'Back to the issue index'; br; br; $is->htmlForm(undef, "/$p/issue/post"); $s->htmlFooter; } sub issue_post { my($s, $p) = @_; return $s->resNotFound if $s->reqMethod() ne 'POST'; my $is = _issue_init($s, $p); my($f, $l) = $is->handleForm(sub { "http://dev.yorhel.nl/$p/issue/".shift }); if($f->{_err}) { $s->htmlHeader(title => 'Error creating message', page => $p, sec => 'issue'); 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/issue_// ;"\u$f"} @{$f->{_err}}).'.'; return $s->htmlFooter; } $s->resRedirect("/$p/issue/$l->{issue}", 'post'); } sub issue_item { my($s, $p, $i) = @_; my $is = _issue_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 => 'issue'); br; a href => "/$p/issue", 'Back to the issue index'; br; br; $is->htmlItem($item); $is->htmlForm($last, "/$p/issue/post") if !$last->{closed}; br; a href => "/$p/issue", 'Back to the issue 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 = (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'; h1 class => 'title', '~ Menu ~'; $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://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) = @_; my $m = sub { li; a href => $_[0], $_[0]!~/^\//?(class=>'external'):$_[2]?(class=>'menusel'):(), $_[1]; if($_[2] && $_[3]) { ul; $_[3]->(); end; } end; }; ul; $m->('/', 'Home', !$o{page}); $m->('/ncdu', 'Ncdu', $o{page} eq 'ncdu', sub { $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/issue', 'Issue tracker', $o{sec} eq 'issue'); }); $m->('/ncdc', 'Ncdc', $o{page} eq 'ncdc', sub { $m->('/ncdc', 'Info', !$o{sec}); $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/issue', 'Issue tracker', $o{sec} eq 'issue'); }); $m->('/tuwf', 'Tuwf', $o{page} eq 'tuwf', sub { $m->('/tuwf', 'Info', !$o{sec}); $m->('/tuwf/man', 'Manual', $o{sec} eq 'man', sub { $m->('/tuwf/man', 'Main', !$o{sec2}); $m->('/tuwf/man/db', '::DB', $o{sec2} eq 'db'); $m->('/tuwf/man/misc', '::Misc', $o{sec2} eq 'misc'); $m->('/tuwf/man/request', '::Request', $o{sec2} eq 'request'); $m->('/tuwf/man/response', '::Response', $o{sec2} eq 'response'); $m->('/tuwf/man/xml', '::XML', $o{sec2} eq 'xml'); }); $m->('/tuwf/changes', 'Changelog', $o{sec} eq 'changes'); }); $m->('/doc', 'Articles', $o{page} eq 'doc'); $m->('/dump', 'Code dump', $o{page} eq 'dump', sub { $m->('/dump', 'Misc.', !$o{sec}); $m->('/demo', 'Demos', $o{sec} eq 'demo'); $m->('/dump/awshrink','AWShrink', $o{sec} eq 'awshrink'); $m->('/dump/grenamr', 'Grenamr', $o{sec} eq 'grenamr'); $m->('/dump/nccolour','NC-Colour', $o{sec} eq 'nccolour'); }); end; }