#!/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-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,
);
TUWF::set(
logfile => '/www/err.log',
error_404_handler => \¬found,
# 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;
}
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 ([^ ]+) ([^ ]+) ([^\]]*)\]//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;
style type => 'text/css';
$s->printCSS;
end;
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';
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|