diff --git a/README.md b/README.md index 0c2a007..1d30d71 100644 --- a/README.md +++ b/README.md @@ -7,18 +7,14 @@ Ironically, documentation about how things work is completely lacking. ## Requirements -- perl: A somewhat recent version (no idea which, due to my XS usage) -- postgresql: Also a somewhat recent version +- perl: 5.36+ +- postgresql: A somewhat recent version - rust: Version who-knows-which ### Web front-end +- FU - AnyEvent -- DBD::Pg -- DBI -- JSON::XS -- SQL::Interp -- TUWF ### Man page indexer diff --git a/www/index.pl b/www/index.pl index ad438ea..a5738e4 100755 --- a/www/index.pl +++ b/www/index.pl @@ -1,11 +1,12 @@ #!/usr/bin/perl -use v5.26; -use warnings; -use TUWF ':html5_', 'uri_escape'; +use v5.36; +use FU -spawn; +use FU::SQL; +use FU::XMLWriter ':html5_'; +use FU::Util 'httpdate_format', 'uri_escape'; use POSIX 'ceil'; use List::Util 'uniq', 'min'; -use SQL::Interp 'sql', 'sql_interp'; use Time::Local 'timegm'; use Cwd 'abs_path'; @@ -13,47 +14,28 @@ our $ROOT; BEGIN { ($ROOT = abs_path $0) =~ s{/www/index\.pl$}{}; } # Force the pure-perl AnyEvent backend; More lightweight and we don't need the -# performance of EV. Fixes an issue with subprocess spawning under TUWF's -# built-in web server that I haven't been able to track down. +# performance of EV. BEGIN { $ENV{PERL_ANYEVENT_MODEL} = 'Perl'; } use lib "$ROOT/lib/ManUtils/inst/lib/perl5"; use ManUtils; -TUWF::set( - logfile => $ENV{TUWF_LOG}, - db_login => [undef, undef, undef], - debug => $ENV{TUWF_DEBUG}, - xml_pretty => 0, - log_slow_pages => 500, -); +FU::init_db(''); # Must be configured through env vars +FU::log_slow_reqs 500; -TUWF::hook before => sub { - if(tuwf->resFile("$ROOT/www", tuwf->reqPath)) { - tuwf->resHeader('Cache-Control' => 'max-age=31536000'); - tuwf->done; - } +FU::before_request { + fu->set_header('cache-control' => 'max-age=31536000'); + fu->send_file("$ROOT/www", fu->path); + fu->reset; }; -# TODO: Add SQL::Interp support to TUWF directly, in some form. -sub TUWF::Object::dbExeci { shift->dbExec(sql_interp @_) } -sub TUWF::Object::dbVali { shift->dbVal (sql_interp @_) } -sub TUWF::Object::dbRowi { shift->dbRow (sql_interp @_) } -sub TUWF::Object::dbAlli { shift->dbAll (sql_interp @_) } -sub TUWF::Object::dbPagei { shift->dbPage(shift, sql_interp @_) } - # Set the last modification time from a string in yyyy-mm-dd format. -sub TUWF::Object::resLastMod { - my($s, $d) = @_; +sub FU::obj::set_lastmod($, $d) { return if $d !~ /^(\d{4})-(\d{2})-(\d{2})/; - my @t = gmtime timegm 0,0,0,$3,$2-1,$1; - $s->resHeader('Last-Modified', sprintf '%s, %02d %s %04d %02d:%02d:%02d GMT', - (qw|Sun Mon Tue Wed Thu Fri Sat|)[$t[6]], $t[3], - (qw|Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec|)[$t[4]], - $t[5]+1900, $t[2], $t[1], $t[0]); + fu->set_header('last-modified', httpdate_format timegm 0,0,0,$3,$2-1,$1); } @@ -62,7 +44,7 @@ sub systems { state $s ||= [ map { $_->{full} = $_->{name}.($_->{release}?' '.$_->{release}:''); $_ - } tuwf->dbAll('SELECT id, name, release, short FROM systems ORDER BY name, id')->@* ]; + } fu->sql('SELECT id, name, release, short FROM systems ORDER BY name, id')->allh->@* ]; } sub sysbyid { state $s ||= { map +($_->{id}, $_), systems->@* } } @@ -77,19 +59,9 @@ sub shorthash_to_int { unpack 'i', pack 'H*', $_[0] } # hex -> int sub escape_like { $_[0] =~ s/([_%\\])/\\$1/rg } -sub sql_join { - my $sep = shift; - my @args = map +($sep, $_), @_; - sql @args[1..$#args]; -} -sub sql_and { @_ ? sql_join 'AND', map sql('(', $_, ')'), @_ : sql '1=1' } -sub sql_or { @_ ? sql_join 'OR', map sql('(', $_, ')'), @_ : sql '1=0' } - # Returns ($pkg_obj, $ver_str, $should_redir) -sub pkg_frompath { - my($sys_where, $path) = @_; - +sub pkg_frompath($sys_where, $path) { # $path could either be: # $name # $name/$version @@ -104,15 +76,13 @@ sub pkg_frompath { my @comp = split '/', $path; my @names = map join('/', @$_), map +([@comp[$_..$#comp]], [@comp[$_..$#comp-1]]), 0..$#comp; - my $pkg = tuwf->dbRowi(' + my $pkg = fu->SQL(' SELECT id, system, name FROM packages p - WHERE c_hasman AND', $sys_where, 'AND name IN', \@names, ' + WHERE c_hasman AND', $sys_where, 'AND name', IN \@names, ' ORDER BY system DESC, length(name) DESC LIMIT 1 - '); - - return (undef, '', 0) if !$pkg->{id}; + ')->rowh || return (undef, '', 0); my $ver = $path =~ m{\Q$pkg->{name}\E/([^/]+)$} ? $1 : ''; ($pkg, $ver, $path !~ /^\Q$pkg->{name}/); @@ -120,9 +90,8 @@ sub pkg_frompath { # Get the preferred man page for the given filters. -sub man_pref { - my($section, $where) = @_; - $where = sql_and $where, sql 'm.section LIKE', \(escape_like($section).'%') if length $section; +sub man_pref($section, $where) { + $where = AND $where, SQL 'm.section LIKE', escape_like($section).'%' if length $section; # Criteria to determine a "preferred" man page: # 1. english: English versions of a man page have preference over other locales @@ -140,7 +109,7 @@ sub man_pref { state $archid = sysbyshort->{arch}{id}; state $debid = (sort { $b->{id} <=> $a->{id} } grep $_->{short} =~ /^debian-/, systems->@*)[0]{id}; - tuwf->dbRowi(q{ + fu->SQL(q{ WITH unfiltered AS ( SELECT m.name, m.section, l.locale, f.shorthash, f.content, f.filename, s AS sys, p AS pkg, v AS ver FROM files f @@ -157,9 +126,9 @@ sub man_pref { ), f_stdloc AS( SELECT * FROM f_pkgver WHERE NOT EXISTS(SELECT 1 FROM f_pkgver WHERE is_standard_man_location(filename)) OR is_standard_man_location(filename) ), f_secmatch AS( - SELECT * FROM f_stdloc WHERE NOT EXISTS(SELECT 1 FROM f_stdloc WHERE section =}, \$section, q{) OR section =}, \$section, q{ + SELECT * FROM f_stdloc WHERE NOT EXISTS(SELECT 1 FROM f_stdloc WHERE section =}, $section, q{) OR section =}, $section, q{ ), f_arch AS( - SELECT * FROM f_secmatch WHERE NOT EXISTS(SELECT 1 FROM}, length $section ? 'f_secmatch' : 'f_stdloc', qq{WHERE (sys).id = $archid) OR (sys).id = $archid + SELECT * FROM f_secmatch WHERE NOT EXISTS(SELECT 1 FROM}, length $section ? 'f_secmatch' : 'f_stdloc', RAW qq{WHERE (sys).id = $archid) OR (sys).id = $archid ), f_debian AS( SELECT * FROM f_arch WHERE NOT EXISTS(SELECT 1 FROM f_arch WHERE (sys).id = $debid) OR (sys).id = $debid ), f_sysrel AS( @@ -172,39 +141,36 @@ sub man_pref { SELECT (pkg).system, (pkg).name AS package, (ver).version, (ver).released, (ver).id AS verid, name, section, filename, locale, shorthash, content FROM f_pkgdate ORDER BY shorthash LIMIT 1 - }); + })->rowh; } # Given the name of a man page with optional section, find out the actual name # and section suffix of the man page and the preferred version. -sub man_pref_name { - my($name, $where) = @_; - +sub man_pref_name($name, $where) { # Check the .
format first, because ~most~ cases where # there's a collision in the format, the -only page is either # uninteresting or a file name parsing error. if ($name =~ /^(.+)\.([^.]+)$/) { my($n, $s) = ($1,$2); - my $man = man_pref $s, sql_and $where, sql 'm.name =', \$n; - return ($man, $s) if length $man->{name}; + my $man = man_pref $s, AND $where, SQL 'm.name =', $n; + return ($man, $s) if $man; } - my $man = man_pref undef, sql_and $where, sql 'm.name =', \$name; - length $man->{name} ? ($man, '') : (undef, ''); + my $man = man_pref undef, AND $where, SQL 'm.name =', $name; + $man ? ($man, '') : (undef, ''); } -sub man_languages { - my($name, $sect) = @_; - [ map $_->{locale}, tuwf->dbAlli( - "SELECT DISTINCT l.locale +sub man_languages($name, $sect) { + fu->SQL( + 'SELECT DISTINCT l.locale FROM files f JOIN mans m ON m.id = f.man JOIN locales l ON l.id = f.locale - WHERE m.name =", \$name, 'AND m.section =', \$sect, " - ORDER BY l.locale" - )->@* ]; + WHERE m.name =', $name, 'AND m.section =', $sect, ' + ORDER BY l.locale' + )->flat; } @@ -212,7 +178,7 @@ sub framework_ { my $content = pop; my(%o) = @_; - html_ lang => 'en', sub { + fu->set_body(html_ lang => 'en', sub { head_ sub { link_ rel => 'stylesheet', type => 'text/css', href => '/man.css?7'; title_ $o{title}.' - manned.org'; @@ -235,31 +201,11 @@ sub framework_ { span_ 'all manual pages are copyrighted by their respective authors.'; }; } - }; - - # write the SQL queries as a HTML comment when debugging is enabled - # (stolen from VNDB code) - # (TODO: Move this into TUWF or something) - if(tuwf->debug) { - my(@sql_r, @sql_i) = (); - for (tuwf->{_TUWF}{DB}{queries}->@*) { - my($sql, $params, $time) = @$_; - my @params = sort { $a =~ /^[0-9]+$/ && $b =~ /^[0-9]+$/ ? $a <=> $b : $a cmp $b } keys %$params; - my $prefix = sprintf " [%6.2fms] ", $time*1000; - push @sql_r, sprintf "%s%s | %s", $prefix, $sql, join ', ', map "$_:".DBI::neat($params->{$_}), @params; - my $i=1; - push @sql_i, $prefix.($sql =~ s/\?/tuwf->dbh->quote($params->{$i++})/egr); - } - my $sql_r = join "\n", @sql_r; - my $sql_i = join "\n", @sql_i; - my $modules = join "\n", sort keys %INC; - lit_ "\n"; - } + }); } -sub paginate_ { - my($url, $count, $perpage, $p) = @_; +sub paginate_($url, $count, $perpage, $p) { return if $count <= $perpage; my sub l_ { @@ -279,9 +225,8 @@ sub paginate_ { } -TUWF::set error_404_handler => sub { - tuwf->resStatus(404); - my $title = 'No manual entry for '.tuwf->reqPath; +FU::on_error 404 => sub { + my $title = 'No manual entry for '.fu->path; framework_ title => $title, sub { h1_ $title; p_ 'That is, the page you were looking for doesn\'t exist.'; @@ -289,8 +234,8 @@ TUWF::set error_404_handler => sub { }; -TUWF::get '/' => sub { - my $stats = tuwf->dbRow('SELECT * FROM stats_cache'); +FU::get '/' => sub { + my $stats = fu->sql('SELECT * FROM stats_cache')->rowh; sub num { local $_=shift; 1 while(s/(\d)(\d{3})($|,)/$1,$2/); $_ }; @@ -357,8 +302,7 @@ TUWF::get '/' => sub { }; }; - -TUWF::get '/info/about' => sub { +FU::get '/info/about' => sub { framework_ title => 'About', mainclass => 'thin', sub { h1_ 'About Manned.org'; lit_ <<' _'; @@ -599,35 +543,35 @@ TUWF::get '/info/about' => sub { }; }; - -TUWF::get '/browse/search' => sub { - my $q = tuwf->reqGet('q')||''; +FU::get '/browse/search' => sub { + my $q = fu->query('q')//''; # TODO: Use schema, this may be an array my $name = $q; my $sect = $name =~ s/^([0-9])\s+// || $name =~ s/\(([a-zA-Z0-9]+)\)$// || $name =~ s/\.([0-9][a-zA-Z0-9]*)$// ? $1 : ''; ($name,$sect) = ($sect,'') if !length $name; # Redirect if we have an exact match - my @sectsql = length $sect ? ('AND section =', \$sect) : (); - my $man = length $name && tuwf->dbRowi('SELECT name, section FROM mans WHERE name =', \$name, @sectsql); - return tuwf->resRedirect("/man/$man->{name}".(length $sect ? ".$man->{section}" : ''), 'temp') if $man && length $man->{name}; + my @sectsql = length $sect ? SQL 'AND section =', $sect : (); + my $man = length $name && fu->SQL('SELECT name, section FROM mans WHERE name =', $name, @sectsql, 'ORDER BY section LIMIT 1')->rowh; + fu->redirect(temp => "/man/$man->{name}".(length $sect ? ".$man->{section}" : '')) if $man; # Otherwise, do case-insensitive glob search my $nameq = escape_like(lc $name) =~ tr/?*/_%/r; - my $lst = !length $nameq ? [] : tuwf->dbAlli(' + my $lst = !length $nameq ? [] : fu->SQL(' SELECT name, section - FROM mans WHERE lower(name) LIKE', \$nameq, @sectsql, ' + FROM mans WHERE lower(name) LIKE', $nameq, @sectsql, ' ORDER BY name, section - LIMIT 500'); + LIMIT 500' + )->alla; framework_ title => 'Search results for '.$q, mainclass => 'searchres', q => $q, sub { h1_ 'Search results for '.(length $sect ? "$name in section $sect" : $q); if(@$lst) { - p_ 'Truncated to the first 500 results.' if @$lst >= 150; + p_ 'Truncated to the first 500 results.' if @$lst >= 500; ul_ sub { li_ sub { - a_ href => "/man/$_->{name}.$_->{section}", $_->{name}; - small_ " $_->{section}"; + a_ href => "/man/$_->[0].$_->[1]", $_->[0]; + small_ " $_->[1]"; } for @$lst; } } else { @@ -680,21 +624,19 @@ package ManUrl { }; -sub man_nav_ { - my($man, $url, $toc, $htmllang) = @_; - - my @systems = tuwf->dbAlli(' +sub man_nav_($man, $url, $toc, $htmllang) { + my $systems = fu->SQL(' SELECT DISTINCT p.system FROM packages p JOIN package_versions v ON v.package = p.id JOIN files f ON f.pkgver = v.id JOIN mans m ON m.id = f.man - WHERE m.name =', \$man->{name}, 'AND m.section =', \$man->{section} - )->@*; + WHERE m.name =', $man->{name}, 'AND m.section =', $man->{section} + )->flat; - my @sect = map $_->{section}, tuwf->dbAlli( - 'SELECT DISTINCT section FROM mans WHERE name =', \$man->{name}, 'ORDER BY section' - )->@*; + my $sect = fu->SQL( + 'SELECT DISTINCT section FROM mans WHERE name =', $man->{name}, 'ORDER BY section' + )->flat; my $lang = man_languages $man->{name}, $man->{section}; @@ -703,7 +645,7 @@ sub man_nav_ { onsubmit => 'location.href="/man/"+system_select[system_select.selectedIndex].value+"/'.$url->mansect().'";return false', sub { my %names; - push $names{$_->{name}}->@*, $_ for map sysbyid->{$_->{system}}, sort { $b->{system} <=> $a->{system} } @systems; + push $names{$_->{name}}->@*, $_ for map sysbyid->{$_}, sort { $b <=> $a } @$systems; select_ id => 'system_select', name => 'system', sub { for (sort { ($names{$b}->@* == 1) <=> ($names{$a}->@* == 1) || $a cmp $b } keys %names) { my $s = $names{$_}; @@ -717,16 +659,16 @@ sub man_nav_ { } }; input_ type => 'submit', value => 'Go'; - } if @systems > 1; + } if @$systems > 1; # TODO: This is ugly, especially because clicking on a translation or # section, you can end up with a man page that is nowhere close to the # man page you're currently reading. Sections or languages available # for the currently selected system should be highlighted. - if(@sect > 1) { + if(@$sect > 1) { b_ 'Sections'; p_ sub { - for (@sect) { + for (@$sect) { if($man->{section} eq $_) { i_ $_; } else { @@ -767,9 +709,7 @@ sub man_nav_ { # Replace .so's in man source with the contents (if available in the same # package) or with a reference to the other man page. -sub soelim { - my($verid, $src) = @_; - +sub soelim($verid, $src) { # tix comes with* a custom(?) macro package. But it looks okay even without loading that. # (* It actually doesn't, the tcllib package appears to have that file, but doesn't '.so' it) $src =~ s/^\.so man.macros$//mg; @@ -778,36 +718,37 @@ sub soelim { $src =~ s{^\.so (.+)$}{ my $path = $1; my $name = (reverse split /\//, $path)[0]; - my($man) = $verid ? man_pref_name $name, sql 'v.id =', \$verid : (); + my($man) = $verid ? man_pref_name $name, SQL 'v.id =', $verid : (); $man->{name} # Recursive soelim, but the second call gets $verid=0 so we don't keep checking the database - ? soelim(0, tuwf->dbVali("SELECT content FROM contents WHERE id =", \$man->{content})) + ? soelim(0, fu->SQL('SELECT content FROM contents WHERE id =', $man->{content})->val) : ".in -10\n.sp\n\[\[\[MANNEDINCLUDE$path\]\]\]" }emg; $src; } -sub man_page { - my($man, $url) = @_; - tuwf->resLastMod($man->{released}); +sub man_page($man, $url) { + fu->set_lastmod($man->{released}); - my $content = tuwf->dbRowi('SELECT encode(hash, \'hex\') AS hash, content FROM contents WHERE id =', \$man->{content}); + my($hash, $content) = fu->SQL('SELECT encode(hash, \'hex\') AS hash, content FROM contents WHERE id =', $man->{content})->rowl; if($url->{fmt} eq 'raw') { - tuwf->resHeader('Content-Type', 'text/plain; charset=UTF-8'); - tuwf->resHeader('Content-Disposition', sprintf 'filename="%s.%s"', $man->{name}, $man->{section}); - lit_ $content->{content}; - return; + fu->set_header('content-type', 'text/plain'); + fu->set_header('content-disposition', sprintf 'filename="%s.%s"', $man->{name}, $man->{section}); + utf8::encode($content); + fu->set_body($content); + fu->done; } - my $fmt = ManUtils::html ManUtils::fmt_block soelim $man->{verid}, $content->{content}; + my $fmt = ManUtils::html ManUtils::fmt_block soelim $man->{verid}, $content; if($url->{fmt} eq 'txt') { # TODO: The 'txt' format is kind of broken right now as it includes our HTML formatting codes. # This feature is a WIP and not advertised at the moment, anyway. - tuwf->resHeader('Content-Type', 'text/plain; charset=UTF-8'); - tuwf->resHeader('Content-Disposition', sprintf 'filename="%s.%s.txt"', $man->{name}, $man->{section}); - lit_ $fmt; - return; + fu->set_header('content-type', 'text/plain; charset=UTF-8'); + fu->set_header('content-disposition', sprintf 'filename="%s.%s.txt"', $man->{name}, $man->{section}); + utf8::encode($fmt); + fu->set_body($fmt); + fu->done; } # Prefix links to other man pages with the current system, to ensure we @@ -833,7 +774,7 @@ sub man_page { li_ sub { a_ href => $url->set(fmt => 'raw'), 'source' }; li_ sub { a_ href => $url->set(system => sysbyid->{$man->{system}}{short}, package => undef, shorthash => shorthash_to_hex $man->{shorthash}), 'permalink' }; li_ sub { a_ href => "/ver.".shorthash_to_hex($man->{shorthash}).($man->{locale}?".$man->{locale}":'')."/$man->{name}.$man->{section}", 'versions' }; - li_ sub { a_ href => "/loc/$content->{hash}", 'locations' }; + li_ sub { a_ href => "/loc/$hash", 'locations' }; } }; pre_ @htmllang, sub { lit_ $fmt }; @@ -845,12 +786,11 @@ sub man_page { # // - old permalink format # This one has to go before the other mappings, to ensure that links work for # man pages called 'pkg' or 'man'. -TUWF::get qr{/(?[^/]+)(?:/(?[0-9a-f]{8}))?} => sub { - my $name = normalize_name tuwf->capture('name'); - my $shorthash = tuwf->capture('hash'); +FU::get qr{/([^/]+)(?:/([0-9a-f]{8}))?} => sub($name, $shorthash=undef) { + $name = normalize_name $name; - my($man, $sect) = man_pref_name $name, $shorthash ? sql 'f.shorthash =', \shorthash_to_int $shorthash : 'true'; - return tuwf->resNotFound() if !$man->{name}; + my($man, $sect) = man_pref_name $name, $shorthash ? SQL 'f.shorthash =', shorthash_to_int $shorthash : 'true'; + fu->error(404) if !$man->{name}; man_page $man, ManUrl->new( fmt => 'man', @@ -861,19 +801,16 @@ TUWF::get qr{/(?[^/]+)(?:/(?[0-9a-f]{8}))?} => sub { # ///src - old URL format to get the raw man page -TUWF::get qr{/([^/]+)/([0-9a-f]{8})/src} => sub { - my $name = normalize_name tuwf->capture(1); - my $shorthash = tuwf->capture(2); +FU::get qr{/([^/]+)/([0-9a-f]{8})/src} => sub($name, $shorthash) { + $name = normalize_name $name; - my($man) = man_pref_name $name, sql 'f.shorthash =', \shorthash_to_int $shorthash; - return tuwf->resNotFound if !$man->{name}; + my($man) = man_pref_name $name, SQL 'f.shorthash =', shorthash_to_int $shorthash; + fu->error(404) if !$man->{name}; man_page $man, ManUrl->new(fmt => 'raw', man => $name); }; -TUWF::get qr{/(?man|txt|raw)(?:\.(?[a-fA-F0-9]{8}))?(?:\.(?[^/]+))?/(?.+)} => sub { - my($fmt, $shorthash, $lang, $path) = tuwf->captures(qw|fmt shorthash lang path|); - +FU::get qr{/(man|txt|raw)(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/(.+)} => sub($fmt, $shorthash, $lang, $path) { my @where; my $name = normalize_name($path =~ s{/?([^/]+)$}{} && $1); my $system = $path =~ s{^([^/]+)/?}{} && $1; @@ -882,20 +819,20 @@ TUWF::get qr{/(?man|txt|raw)(?:\.(?[a-fA-F0-9]{8}))?(?:\.(?{$system}; $sysid = $sysid ? [$sysid->{id}] : [ map sysbyshort->{$_}{id}, grep /^\Q$system\E-/, keys sysbyshort->%* ]; - return tuwf->resNotFound if !@$sysid; - push @where, sql 'system IN', $sysid; + fu->error(404) if !@$sysid; + push @where, SQL system => IN $sysid; } - my($pkg, $ver, $redir) = length $path ? pkg_frompath sql_and(@where), $path : (undef,undef); - return tuwf->resNotFound if length $path && !$pkg; - push @where, sql 'p.id =', \$pkg->{id} if $pkg; - push @where, sql 'v.version =', \$ver if length $ver; + my($pkg, $ver, $redir) = length $path ? pkg_frompath AND(@where), $path : (undef,undef); + fu->error(404) if length $path && !$pkg; + push @where, SQL 'p.id =', $pkg->{id} if $pkg; + push @where, SQL 'v.version =', $ver if length $ver; - push @where, sql 'f.shorthash =', \shorthash_to_int $shorthash if $shorthash; - push @where, sql 'l.locale =', \$lang if $lang; + push @where, SQL 'f.shorthash =', shorthash_to_int $shorthash if $shorthash; + push @where, SQL 'l.locale =', $lang if $lang; - my($man, $section) = man_pref_name $name, sql_and @where; - return tuwf->resNotFound if !$man; + my($man, $section) = man_pref_name $name, AND @where; + fu->error(404) if !$man; my $url = ManUrl->new( fmt => $fmt, @@ -907,27 +844,31 @@ TUWF::get qr{/(?man|txt|raw)(?:\.(?[a-fA-F0-9]{8}))?(?:\.(? length $section ? $man->{name} : $name, section => length $section ? $section : undef, ); - return tuwf->resRedirect($url, 'perm') if $redir; + fu->redirect(perm => $url) if $redir; man_page $man, $url; }; -TUWF::get qr{/pkg/([^/]+)} => sub { - my $short = tuwf->capture(1); - +FU::get qr{/pkg/([^/]+)} => sub($short) { my $sys = sysbyshort->{$short}; - return tuwf->resNotFound if !$sys; + fu->error(404) if !$sys; - my $f = tuwf->validate(get => - c => { onerror => 'all', enum => [ '0', 'all', 'a'..'z' ] }, - p => { onerror => 1, uint => 1, range => [1,200] }, - )->data; + $FU::REQ->{qs} =~ s/;/&/g if $FU::REQ->{qs}; # HACK: old URLs used ';' as separator instead of '&' + my $f = { + c => fu->query('c')//'all', + p => fu->query('p')//1, + }; + # TODO: + #my $f = tuwf->validate(get => + # c => { onerror => 'all', enum => [ '0', 'all', 'a'..'z' ] }, + # p => { onerror => 1, uint => 1, range => [1,200] }, + #)->data; - my $where = sql 'c_hasman AND NOT dead AND system =', \$sys->{id}, $f->{c} ne 'all' ? ('AND match_firstchar(name,', \$f->{c}, ')') : (); - my $count = tuwf->dbVali('SELECT count(*) FROM packages p WHERE', $where); - my $pkg = tuwf->dbPagei({ results => 200, page => $f->{p} }, - 'SELECT id, system, name FROM packages p WHERE', $where, 'ORDER BY name' - ); + my $where = SQL 'c_hasman AND NOT dead AND system =', $sys->{id}, $f->{c} ne 'all' ? ('AND match_firstchar(name,', $f->{c}, ')') : (); + my $count = fu->SQL('SELECT count(*) FROM packages p WHERE', $where)->val; + my $pkg = fu->SQL( + 'SELECT id, system, name FROM packages p WHERE', $where, 'ORDER BY name LIMIT 200 OFFSET', ($f->{p}-1)*200, + )->allh; framework_ title => $sys->{full}, mainclass => 'pkglist', sub { div_ sub { @@ -943,48 +884,46 @@ TUWF::get qr{/pkg/([^/]+)} => sub { }; small_ '(Packages without man pages are not listed)'; - paginate_ "/pkg/$short?c=$f->{c};p=", $count, 200, $f->{p}; + paginate_ "/pkg/$short?c=$f->{c}&p=", $count, 200, $f->{p}; ul_ sub { li_ sub { a_ href => "/pkg/$short/$_->{name}", $_->{name}; } for @$pkg; }; - paginate_ "/pkg/$short?c=$f->{c};p=", $count, 200, $f->{p}; + paginate_ "/pkg/$short?c=$f->{c}&p=", $count, 200, $f->{p}; }; }; # Package info: /pkg/$system[/$category]/$name[/$version]; $category and $name may contain slashes, too. -TUWF::get qr{/pkg/([^/]+)/(.+)} => sub { - my ($short, $path) = tuwf->captures(1,2); - +FU::get qr{/pkg/([^/]+)/(.+)} => sub($short, $path) { my $sys = sysbyshort->{$short}; - return tuwf->resNotFound if !$sys; + fu->error(404) if !$sys; - my($pkg, $ver, $redir) = pkg_frompath(sql('system =', \$sys->{id}), $path); - return tuwf->resNotFound if !$pkg; - return tuwf->resRedirect("/pkg/$short/$pkg->{name}".($ver?"/$ver":''), 'perm') if $redir; + my($pkg, $ver, $redir) = pkg_frompath(SQL('system =', $sys->{id}), $path); + fu->error(404) if !$pkg; + fu->redirect(perm => "/pkg/$short/$pkg->{name}".($ver?"/$ver":'')) if $redir; - my $vers = tuwf->dbAlli(' + my $vers = fu->SQL(' SELECT id, version, released FROM package_versions v - WHERE package =', \$pkg->{id}, ' + WHERE package =', $pkg->{id}, ' AND EXISTS(SELECT 1 FROM files f WHERE f.pkgver = v.id) ORDER BY released DESC' - ); + )->allh; my $sel = $ver ? (grep $_->{version} eq $ver, @$vers)[0] : $vers->[0]; - return tuwf->resNotFound if !$sel; + fu->error(404) if !$sel; - my $p = tuwf->validate(get => p => { onerror => 1, uint => 1, range => [1,100] })->data; + my $p = fu->query('p')//1; # TODO: tuwf->validate(get => p => { onerror => 1, uint => 1, range => [1,100] })->data; - my $count = tuwf->dbVali('SELECT count(*) FROM files WHERE pkgver =', \$sel->{id}); - my $mans = tuwf->dbPagei({ results => 200, page => $p }, ' + my $count = fu->SQL('SELECT count(*) FROM files WHERE pkgver =', $sel->{id})->val; + my $mans = fu->SQL(' WITH lst AS ( SELECT f.man, m.name, m.section, f.shorthash, f.filename, l.locale FROM files f JOIN locales l ON l.id = f.locale JOIN mans m ON m.id = f.man - WHERE f.pkgver =', \$sel->{id}, ' + WHERE f.pkgver =', $sel->{id}, ' ), needlang AS ( SELECT man FROM lst GROUP BY man HAVING count(*) > 1 ), needhash AS ( @@ -994,10 +933,11 @@ TUWF::get qr{/pkg/([^/]+)/(.+)} => sub { , EXISTS(SELECT 1 FROM needhash WHERE man = l.man AND locale = l.locale) AS needhash FROM lst l ORDER BY name, section, locale, filename - '); + LIMIT 200 OFFSET', ($p-1)*200 + )->allh; # Latest version of this package determines last modification date of the page. - tuwf->resLastMod($vers->[0]{released}); + fu->set_lastmod($vers->[0]{released}); my $subtitle = " / $pkg->{name}"; my $pkgpath = "$sys->{short}/$pkg->{name}"; @@ -1038,37 +978,35 @@ TUWF::get qr{/pkg/([^/]+)/(.+)} => sub { }; # /browse/ has been moved to /pkg/. -TUWF::get qr{/browse/(.+)} => sub { tuwf->resRedirect('/pkg/'.tuwf->capture(1), 'perm') }; +FU::get qr{/browse/(.+)} => sub($pkg) { fu->redirect(perm => "/pkg/$pkg") }; # Redirect for the system selection box, for visitors who have disabled JS. -TUWF::get qr{/sysredir/([^/]+)} => sub { tuwf->resRedirect('/man/'.(tuwf->reqGet('system')//'arch').'/'.tuwf->capture(1), 'temp') }; +FU::get qr{/sysredir/([^/]+)} => sub($path) { fu->redirect(temp => '/man/'.(fu->query('system')//'arch')."/$path", 'temp') }; # Redirect for a specific language for a man page. I have no idea if anyone # still uses this URL format, but it was supported at some point, so let's keep # it around. -TUWF::get qr{/lang/([^/]+)/([^/]+)} => sub { tuwf->resRedirect('/man.'.tuwf->capture(1).'/'.tuwf->capture(2), 'temp') }; +FU::get qr{/lang/([^/]+)/([^/]+)} => sub($lang, $man) { fu->redirect(temp => "/man.$lang/$man") }; -TUWF::get qr{/loc/([a-fA-F0-9]{40})}, sub { - my $hash = tuwf->capture(1); - +FU::get qr{/loc/([a-fA-F0-9]{40})}, sub($hash) { # There are a few files that have been duplicated far too many times for # this page to be very useful. Add some limits to make sure the page at # least manages to load something. my $maxlisting = 30_000; my $maxpersys = 500; - my $l = tuwf->dbAlli(' + my $l = fu->SQL(' SELECT p.system, p.name AS package, v.version, f.filename, f.shorthash, m.name, m.section FROM files f JOIN mans m ON m.id = f.man JOIN package_versions v ON v.id = f.pkgver JOIN packages p ON p.id = v.package - WHERE f.content = (SELECT id FROM contents WHERE hash = decode(', \$hash, ", 'hex')) + WHERE f.content = (SELECT id FROM contents WHERE hash = decode(', $hash, ", 'hex')) ORDER BY p.system DESC, p.name, v.released DESC, f.filename - LIMIT ", \$maxlisting - ); - return tuwf->resNotFound() if !@$l; + LIMIT ", $maxlisting + )->allh; + fu->error(404) if !@$l; my %sys; push $sys{ sysbyid->{$_->{system}}{name} }->@*, $_ for @$l; @@ -1132,25 +1070,21 @@ TUWF::get qr{/loc/([a-fA-F0-9]{40})}, sub { # /ver[.$shorthash][.$lang]/$name.$section -TUWF::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)}, sub { - my($shorthash, $lang, $name, $sect) = tuwf->captures(1,2,3,4); +FU::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)}, sub($shorthash, $lang, $name, $sect) { $shorthash = $shorthash ? shorthash_to_int $shorthash : -1; $lang ||= ''; - my $l = tuwf->dbAlli(' + my $l = fu->SQL(' SELECT p.system, p.name AS package, v.version, v.released, f.shorthash FROM files f JOIN package_versions v ON v.id = f.pkgver JOIN packages p ON p.id = v.package - WHERE f.man = (SELECT id FROM mans WHERE name =', \$name, 'AND section =', \$sect, ') - AND f.locale IN(SELECT id FROM locales WHERE locale =', \$lang, ') + WHERE f.man = (SELECT id FROM mans WHERE name =', $name, 'AND section =', $sect, ') + AND f.locale IN(SELECT id FROM locales WHERE locale =', $lang, ') ORDER BY p.system DESC, p.name, v.released DESC, f.shorthash - '); - - my @sect = map $_->{section}, tuwf->dbAlli( - 'SELECT DISTINCT section FROM mans WHERE name =', \$name, 'ORDER BY section' - )->@*; + ')->allh; + my $sectl = fu->SQL('SELECT DISTINCT section FROM mans WHERE name =', $name, 'ORDER BY section')->flat; my $langs = man_languages $name, $sect; my %sys; @@ -1162,16 +1096,16 @@ TUWF::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)}, p_ sub { txt_ 'Alternative sections: '; - for (0..$#sect) { + for (0..$#{$sectl}) { txt_ ', ' if $_ > 0; - if(($sect[$_]||'') eq $sect) { - b_ $sect[$_]; + if(($sectl->[$_]||'') eq $sect) { + b_ $sectl->[$_]; } else { - a_ href => '/ver'.($lang?".$lang":'')."/$name.$sect[$_]", $sect[$_]; + a_ href => '/ver'.($lang?".$lang":'')."/$name.$sectl->[$_]", $sectl->[$_]; } } txt_ '.'; - } if @sect > 1; + } if @$sectl > 1; p_ sub { txt_ 'Available languages: '; @@ -1225,5 +1159,4 @@ TUWF::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)}, }; }; - -TUWF::run(); +FU::run();