vndb/manned
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit

Browse source
This commit is contained in:
Yorhel 2012-06-15 14:23:29 +02:00
commit c47f450934
11 changed files with 1271 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

12
Makefile Normal file
View file

@ -0,0 +1,12 @@
.PHONY: GrottyParser
GrottyParser: lib/GrottyParser/Build
cd lib/GrottyParser && ./Build install --install-base=inst
lib/GrottyParser/Build: lib/GrottyParser/Build.PL
cd lib/GrottyParser && perl Build.PL
clean:
cd lib/GrottyParser && ./Build distclean
rm -rf lib/GrottyParser/inst

15
lib/GrottyParser/Build.PL Normal file
View file

@ -0,0 +1,15 @@
#!/usr/bin/perl
use Module::Build;
Module::Build->new(
dist_name => 'GrottyParser',
dist_version_from => 'GrottyParser.pm',
pm_files => {
'GrottyParser.pm' => 'lib/GrottyParser.pm',
},
xs_files => {
'GrottyParser.xs' => 'lib/GrottyParser.xs',
},
)->create_build_script;

12
lib/GrottyParser/GrottyParser.pm Normal file
View file

@ -0,0 +1,12 @@
package GrottyParser;
use strict;
use warnings;
our $VERSION = '0.01';
require XSLoader;
XSLoader::load('GrottyParser', $VERSION);
1;

244
lib/GrottyParser/GrottyParser.xs Normal file
View file

@ -0,0 +1,244 @@
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
// Convert grotty output to HTML for use in a <pre> tag.
// It is assumed that the given input string is valid UTF-8, either represented
// as a Perl Unicode string, or as a UTF-8 encoded byte string. The data may
// not contain the 0 character.
// The formatted HTML is returned as a Perl Unicode string.
// It is also assumed that hyphenation has been disabled when generating the
// grotty output.
// This implementation really is fast enough for "real-time" use in the website
// code, very much unlike my experiments with Perl. My previous Perl
// implementation took about 1.5s for rsync(1), whereas I've not seen this
// implementation take more than 15ms.
// TODO: Unicode characters aren't truncated correctly when a line exceeds
// MAXLINE bytes. I've only seen this happening on man pages that grotty
// couldn't wrap, e.g. some Japanese and Chinese mans.
// (Ideally, I'd tell grotty how to wrap those correctly)
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#define MAXLINE 1024
#define LB 1
#define LI 2
typedef struct ctx_t {
const char *src; // Pointer to the source data, or what's left of it.
SV *dest; // Destination string to write to.
// Current line
char line[MAXLINE];
char flags[MAXLINE]; // 0 = no fmt, LB = bold, LI = italic. (No combinations allowed)
int linelen;
int noref; // 1 if the current line shouldn't be checked for references. (Used for first and last line)
} ctx_t;
// Escapes and appends a displayed character to the output string.
static inline void flushescape(ctx_t *x, char c) {
static char str[2] = {};
// Most HTML-escape functions also escape " to &quot;, but since we aren't
// going to put a man page in an XML attribute, we don't really have to worry
// about that one.
switch(c) {
case '>': sv_catpvn(x->dest, "&gt;", 4); break;
case '<': sv_catpvn(x->dest, "&lt;", 4); break;
case '&': sv_catpvn(x->dest, "&amp;", 5); break;
default:
str[0] = c;
sv_catpvn(x->dest, str, 1);
}
}
// HTML-escapes and adds formatting tags to a certain chunk of data and appends
// it to the output string. The chunk is considered as an individual part,
// assuming that any formatting is disabled at the start of the chunk, and
// making sure it is disabled again at the end.
// e points to the last character in s that is not considered part of the chunk.
static void flushchunk(ctx_t *x, const char *s, const char *f, const char *e) {
int fmt = 0;
#define EFMT if(fmt) sv_catpvn(x->dest, fmt == LB ? "</b>" : "</i>", 4)
while(s != e) {
// Consider underscore and whitespace to have the same formatting as the
// previous character. The grotty escape sequences don't work well for the
// underscore character, and you can't see the difference either way.
if(fmt != *f && *s != '_' && *s != ' ') {
EFMT;
fmt = *f;
if(fmt)
sv_catpvn(x->dest, fmt == LB ? "<b>" : "<i>", 3);
}
flushescape(x, *s);
s++;
f++;
}
EFMT;
#undef EFMT
}
#define ismanchar(x) (isalnum(x) || x == '_' || x == '-' || x == '.')
// HTML-escapes and "Flushes" the current line to the output string. Tries to
// convert man references and URLs into links if format is true.
static void flushline(ctx_t *x) {
static const char eol[] = "\n";
char *s = x->line, *es = x->line;
if(x->noref) {
flushchunk(x, x->line, x->flags, x->line+x->linelen);
goto end;
}
#define flush(end) do {\
flushchunk(x, es, x->flags+(es-x->line), end);\
es = end;\
} while(0)
while(*s) {
// Man page reference.
// Detected by the "(x)", but then checked backwards in the buffer to find
// the start of the reference. This is pretty fast. Fails on:
// - JSON.3pm: JSON->new->utf8(1)->pretty(1)->encode($perl_scalar)
if(*s == '(' && (('1' <= s[1] && s[1] <= '9') || s[1] == 'n') && s[2] == ')' && !isalnum(s[3])) {
char *n = s-1;
while(n >= es && ismanchar(*n))
n--;
if(++n < s) {
flush(n);
*s = 0;
sv_catpvf(x->dest, "<a href=\"/%s.%c\">%s(%c)</a>", n, s[1], n, s[1]);
s += 3;
es = s;
continue;
}
}
// HTTP(s) URL.
// This is just a simple q{https?://[^ ][.,;"\)>]?( |$)} match, doesn't
// always work right:
// - chmod.1: <http://gnu.org/licenses/gpl.html>.
// - pod2man.1: <http://www.eyrie.org/~eagle/software/podlators/>.
// - troff.1: ⟨http://www.gnu.org/copyleft/fdl.html⟩. <- yes, that's an Unicode character.
// - roff.7: Has quite a few issues with wrapped URLs and situations similar to the above.
// - JSON.3pm: "RFC4627"(<http://www.ietf.org/rfc/rfc4627.txt>).
// Note: Don't use strncmp() before manually checking for 'http'. The parse
// time is otherwise increased by a factor 2.
if(s[0] == 'h' && s[1] == 't' && s[2] == 't' && s[3] == 'p' && (strncmp(s, "http://", 7) == 0 || strncmp(s, "https://", 8) == 0)) {
char *sep = strchr(s, ' ');
if(!sep)
sep = s+strlen(s);
char *sp = sep;
if(sp > s+10) {
flush(s);
char endchr = *sp;
*(sp--) = 0;
if(*sp == '.' || *sp == ',' || *sp == ';' || *sp == '"' || *sp == ')' || *sp == '>') {
sp[1] = endchr;
endchr = *sp;
*(sp--) = 0;
}
sv_catpvf(x->dest, "<a href=\"%s\" rel=\"nofollow\">%s</a>", s, s);
*(++sp) = endchr;
es = s = sp;
continue;
}
}
s++;
}
flush(s);
#undef flush
end:
sv_catpvn(x->dest, eol, sizeof(eol)-1);
}
// Adds a character to the current line, calls flushline() when a new line is done.
// TODO: Convert \t into spaces? The rest of the code is written with the
// assumption that \t does not occur in the string. I've not seen grotty output
// tabs yet, but it's still a good idea to define what *we* do with tabs.
static void appendline(ctx_t *x, char c, char f) {
if(c == '\r')
return;
if(c == '\n' || x->linelen > MAXLINE+1) {
x->line[x->linelen] = 0;
flushline(x);
x->linelen = 0;
x->noref = 0;
if(c == '\n')
return;
}
x->line[x->linelen] = c;
x->flags[x->linelen] = f;
x->linelen++;
}
// Parses the grotty escapes and calls appendline() for each character.
static void parselines(ctx_t *x) {
int i, ini = 0, inb = 0;
const char *buf = x->src;
while(*buf) {
int c1 = UTF8SKIP(buf);
if(buf[c1] == 8 && buf[c1+1]) {
int c2 = UTF8SKIP(buf+c1+1);
for(i=0; i<c2; i++)
appendline(x, buf[c1+i+1], *buf == '_' ? LI : LB);
buf += c1+c2+1;
continue;
} else {
if(*buf == '\n' && !buf[1])
x->noref = 1;
appendline(x, *buf, 0);
buf++;
}
}
x->noref = 1;
appendline(x, '\n', 0);
}
MODULE = GrottyParser PACKAGE = GrottyParser
SV *
html(str)
SV *str
INIT:
ctx_t *x = malloc(sizeof(ctx_t));
CODE:
x->src = SvPV_nolen(str);
x->dest = newSVpv("", 0);
x->linelen = 0;
x->noref = 1;
parselines(x);
// Set the UTF8 flag *after* generating the result string. For some reason
// that prevents sv_catpvf() from interpreting our C strings as something
// other than UTF-8.
SvUTF8_on(x->dest);
RETVAL = x->dest;
free(x);
OUTPUT:
RETVAL

95
schema.sql Normal file
View file

@ -0,0 +1,95 @@
-- TODO: "system" -> "repository"?
-- TODO: index of (reverse) man page references?
-- TODO: Probably want an index on man(name) and man(hash)
-- TODO: Use some consistent naming of tables and columns
CREATE TABLE systems (
id integer PRIMARY KEY, -- hardcoded ID.
name varchar NOT NULL,
release varchar,
relorder integer NOT NULL DEFAULT 0, -- simple way of ordering different releases for the same system
short varchar NOT NULL
);
CREATE TABLE contents (
hash bytea PRIMARY KEY,
content varchar NOT NULL
);
-- Note: If there are multiple arches available for the same package, then
-- generally only a single one is chosen (not stored here which one).
-- Also, a package may be listed here even if it has no man pages indexed, in
-- order for the fetcher to determine whether it has already processed the
-- package or not. This doesn't mean all packages of a repository are listed
-- here. For example, the Arch fetcher checks the file list of a package before
-- considering to handle it.
CREATE TABLE package (
id SERIAL PRIMARY KEY,
system integer NOT NULL REFERENCES systems(id),
category varchar, -- depends on system (e.g. "community" on Arch, "x11" on Debian)
name varchar NOT NULL,
version varchar NOT NULL,
released date NOT NULL,
UNIQUE(system, name, version)
);
CREATE TABLE man (
package integer NOT NULL REFERENCES package(id),
name varchar NOT NULL, -- 'fopen', 'du', etc (TODO: An index on name_from_filename(filename) may also work)
section varchar NOT NULL, -- extracted from filename (TODO: Is this column really necessary?)
filename varchar NOT NULL, -- full path + file name
locale varchar, -- parsed from the file name, NULL for the "main" man page (in the C or en_US locale)
hash bytea NOT NULL REFERENCES contents(hash),
UNIQUE(package, filename)
);
INSERT INTO systems (id, name, release, short, relorder) VALUES
(1, 'Arch Linux', NULL, 'arch', 0),
(2, 'Ubuntu', '4.10', 'ubuntu-warty', 0),
(3, 'Ubuntu', '5.04', 'ubuntu-hoary', 1),
(4, 'Ubuntu', '5.10', 'ubuntu-breezy', 2);
-- Removes any path components and compression extensions from the filename.
CREATE OR REPLACE FUNCTION basename_from_filename(fn text) RETURNS text AS $$
DECLARE
ret text;
tmp text;
BEGIN
ret := regexp_replace(fn, '^.+/([^/]+)', E'\\1');
LOOP
tmp := regexp_replace(regexp_replace(regexp_replace(ret, E'\\.gz$', ''), E'\\.lzma$', ''), E'\\.bz2$', '');
EXIT WHEN tmp = ret;
ret := tmp;
END LOOP;
RETURN ret;
END;
$$ LANGUAGE plpgsql;
CREATE OR REPLACE FUNCTION section_from_filename(text) RETURNS text AS $$
SELECT regexp_replace(basename_from_filename($1), E'^.+\\.([^.]+)$', E'\\1');
$$ LANGUAGE SQL;
CREATE OR REPLACE FUNCTION name_from_filename(text) RETURNS text AS $$
SELECT regexp_replace(basename_from_filename($1), E'^(.+)\\.[^.]+$', E'\\1');
$$ LANGUAGE SQL;
-- Some handy admin queries
--BEGIN;
--DELETE FROM man WHERE package IN(SELECT id FROM package WHERE name = '');
--DELETE FROM package WHERE name = '';
--DELETE FROM contents c WHERE NOT EXISTS(SELECT 1 FROM man m WHERE m.hash = c.hash);
--COMMIT;

159
util/add_dir.pl Executable file
View file

@ -0,0 +1,159 @@
#!/usr/bin/perl
# Usage: ./add_dir.pl <dir> <pkgid>
# Prints the path names of the found man pages on stdout.
# May throw errors or warnings on stderr.
# Returns 0 if it has added something, 1 on error or if nothing has been found.
use strict;
use warnings;
no warnings 'once';
use Encode 'decode', 'find_encoding', 'decode_utf8';
use Digest::SHA 'sha1_hex';
use File::Find;
use DBI;
die "Not enough arguments\n" if @ARGV < 2;
my($dir, $pkgid) = @ARGV;
my $db = DBI->connect('dbi:Pg:dbname=manned', 'manned', '', {
pg_enable_utf8 => 1, PrintError => 0, RaiseError => 1, AutoCommit => 0
});
sub readman {
my $ofn = shift;
local $/;
open my $F, '<', $ofn or die "Unable to open '$ofn': $!\n";
my $dat = <$F>;
close $F;
# Note: Don't forget to update 'section_from_filename()' in SQL when a new
# compression file extension is recognized.
my $fn = $ofn;
while(1) {
if($fn =~ s/\.gz$//) {
require Compress::Zlib;
$dat = Compress::Zlib::memGunzip($dat);
die "Error decompressing '$ofn': $Compress::Zlib::gzerrno\n" if !defined $dat;
next;
}
if($fn =~ s/\.bz2$//) {
# Don't try to use Compress::Bzip2::memBunzip() here. It's been terribly
# broken for at least 3 years:
# https://rt.cpan.org/Public/Bug/Display.html?id=48128
require Compress::Raw::Bzip2;
my($b, $s) = Compress::Raw::Bunzip2->new();
my $r;
die "Error decompressing '$ofn': Opening bzip2 decompressor: $s\n" if $s != Compress::Raw::Bzip2::BZ_OK();
die "Error decompressing '$ofn': $s\n" if ($s = $b->bzinflate($dat, $r)) != Compress::Raw::Bzip2::BZ_STREAM_END();
$dat = $r;
next;
}
if($fn =~ s/\.lzma$//) {
require Compress::Raw::Lzma;
my($l, $s) = Compress::Raw::Lzma::AutoDecoder->new();
my $r;
die "Error decompressing '$ofn': Opening lzma decompressor: $s\n" if $s != Compress::Raw::Lzma::LZMA_OK();
die "Error decompressing '$ofn': $s\n" if ($s = $l->code($dat, $r)) != Compress::Raw::Lzma::LZMA_STREAM_END();
$dat = $r;
next;
}
last;
}
return $dat;
}
sub decodeman {
my($data, $locale) = @_;
my @enc = ('utf-8'); # No harm in trying utf-8 first.
# Check for 'coding:' indications in the file header.
# According to preconv.1, only the first two lines are checked. I've not seen
# any man page where this coding information was on the second line, though.
# Note that that man page also mentions some aliasses that Perl's
# find_encoding doesn't have. Again, I've not found any man page using those.
my $re = qr/[\.']?\\["#].+-\*-.*coding: *([^ ;]+).+-\*-/;
if($data =~ /^$re/ || $data =~ /^.*\n$re/) {
(my $c = $1) =~ s/-(?:dos|unix|mac)$//;
$c = find_encoding $c;
$c = $c->name if $c;
push @enc, $c if $c && $c ne 'ascii' && $c ne 'utf8' && $c ne 'utf-8-strict';
}
# Get encoding from the locale part of the path
my $locenc = $locale && find_encoding $locale;
unshift @enc, $locenc->name if $locenc;
# Some language-specific fallbacks
# TODO: Handle zh_* locales
$locale && push @enc,
$locale =~ /^(pl|cs|sk)/i ? 'iso-8859-2'
: $locale =~ /^tr/i ? 'iso-8859-9'
: $locale =~ /^ru/i ? 'koi8-r' # TODO: Or iso-8859-5, probably want to autodetect that?
: $locale =~ /^ja/i ? 'euc-jp' # TODO: Works for everything I've found yet, but Japanese isn't that simple. Probably want to detect Shift-JIS as well?
: $locale =~ /^ko/i ? 'euc-kr'
#: $locale =~ /^el/i ? 'iso-8859-7' # So far, all el mans I've seen were UTF-8.
: ();
# If all else fails.
push @enc, 'iso-8859-1';
# Now try decoding
my($dec, $enc);
for(@enc) {
$enc = $_;
$dec = eval { my $tmp = $data; decode($enc, $tmp, 1) };
last if $dec;
}
return $dec ? ($enc, $dec) : ();
}
sub addman {
my($pkg, $path, $fn, $locale) = @_;
my $dat = readman $fn;
my $hash = sha1_hex $dat;
my($enc, $dec) = decodeman($dat, $locale);
print "Invalid encoding or empty file: $path\n" and return if !$enc;
$db->do(q{INSERT INTO contents (hash, content) VALUES(decode(?, 'hex'),?)}, {}, $hash, $dec)
if !$db->selectrow_arrayref(q{SELECT 1 FROM contents WHERE hash = decode(?, 'hex')}, {}, $hash);
$db->do(q{
INSERT INTO man (package, name, section, filename, locale, hash)
VALUES(?,name_from_filename(?),section_from_filename(?),?,?,decode(?, 'hex'))}, {},
$pkg, $path, $path, $path, $locale, $hash);
printf "$path ($enc)\n";
}
my $found = 0;
find sub {
return if !-f $_;
(my $path = $File::Find::name) =~ s/^\Q$dir\E//;
# Note: fltk also creates pre-formatted pages in /cat$sectre/, but those are ignored.
# TODO: Also ignore html and INDEX sections
return warn "Ignoring $path\n" if $path !~ m{man(?:/([^/]+))?/man[0-9n]/([^/]+)$};
addman $pkgid, $path, $2, $1;
$found++;
}, $dir;
if($found) {
$db->commit;
} else {
warn "No man pages found.\n";
$db->rollback;
exit 1;
}

16
util/add_tar.sh Executable file
View file

@ -0,0 +1,16 @@
#!/bin/sh
# Usage: add_tar.sh <file> <pkgid> <flags>
# Requires a recent GNU tar for compression autodetect and xz support.
TMP=`mktemp -d manned.XXXXXXX`
# TODO: tar throws an error if there are no man pages. This isn't really an error, though.
tar --warning=no-unknown-keyword -C "$TMP" $3 -xf "$1" --wildcards '*/man/*'\
&& ./add_dir.pl "$TMP" "$2"
RET=$?
rm -rf "$TMP"
exit $RET

95
util/arch.sh Executable file
View file

@ -0,0 +1,95 @@
#!/bin/sh
# Usage: ./arch.sh
# Synchronises the database with an Arch mirror, fetching any packages that
# aren't yet in the database and may have man pages.
MIRROR=http://ftp.nluug.nl/pub/os/Linux/distr/archlinux
REPOS="core extra community"
DEBUG=false
SYSID=1
CURL="curl -Ss"
PSQL="psql -U manned -Awtq"
TMP=`mktemp -d manned.arch.XXXXXX`
# Returns 0 if the package is already in the database or if an error occured.
# Otherwise adds the package, sets PKGID to the new ID, and returns 1.
PKGID=
add_pkginfo() { # cat name ver date
RES=`echo "SELECT id FROM package WHERE system = :'sysid' AND name = :'name' AND version = :'ver'"\
| $PSQL -v "sysid=$SYSID" -v "name=$2" -v "ver=$3"`
[ "$?" -ne 0 -o -n "$RES" ] && return 0
RES=`echo "INSERT INTO package (system, category, name, version, released) VALUES(:'sysid',:'cat',:'name',:'ver',:'rel') RETURNING id"\
| $PSQL -v "sysid=$SYSID" -v "cat=$1" -v "name=$2" -v "ver=$3" -v "rel=$4"`
[ "$?" -ne 0 ] && return 0
PKGID=$RES
return 1
}
checkpkg() {
REPO=$1
FN=$2
D="$TMP/$REPO/$FN"
if [ ! \( -d "$D" -a -f "$D/files" -a -f "$D/desc" \) ]; then
echo "===> $FN"
echo "Invalid item, ignoring"
return
fi
grep -q /man/ "$D/files"
if [ "$?" -ne 0 ]; then
$DEBUG && echo "===> $FN"
$DEBUG && echo "No mans"
return
fi
# Somewhat inefficient description parsing
FILENAME=`grep -A 1 '%FILENAME%' "$D/desc" | tail -n 1`
NAME=`grep -A 1 '%NAME%' "$D/desc" | tail -n 1`
VERSION=`grep -A 1 '%VERSION%' "$D/desc" | tail -n 1`
BUILDDATE=`grep -A 1 '%BUILDDATE%' "$D/desc" | tail -n 1`
if [ -z "$FILENAME" -o -z "$NAME" -o -z "$VERSION" -o -z "$BUILDDATE" ]; then
echo "===> $FN"
echo "Invalid/missing description info"
return
fi
BUILDDATE=`date -d "@$BUILDDATE" '+%F'`
add_pkginfo "$REPO" "$NAME" "$VERSION" "$BUILDDATE"
if [ "$?" -eq 0 ]; then
$DEBUG && echo "===> $FN"
$DEBUG && echo "Already up-to-date"
return
fi
echo "===> $FN"
F="$TMP/$REPO/$FILENAME"
$CURL "$MIRROR/$REPO/os/i686/$FILENAME" -o "$F" || return
./add_tar.sh "$F" "$PKGID"
rm -f "$F"
}
syncrepo() {
REPO=$1
F="$TMP/$REPO/repo.tar.gz"
echo "============ $REPO"
$CURL "$MIRROR/$REPO/os/i686/$REPO.files.tar.gz" -o "$F" || return 1
tar -C "$TMP/$REPO" -xf "$F" || return 1
rm -f "$F"
for fn in "$TMP/$REPO"/*; do
checkpkg "$REPO" `basename "$fn"`
done
}
for r in $REPOS; do
mkdir "$TMP/$r"
syncrepo $r
rm -rf "$TMP/$r"
done
rm -rf "$TMP"

121
util/deb.sh Executable file
View file

@ -0,0 +1,121 @@
#!/bin/bash
# A fetcher for debian-style repositories.
CURL="curl -Ss"
PSQL="psql -U manned -Awtq"
TMP=`mktemp -d manned.deb.XXXXXX`
checkpkg() {
SYSID=$1
REPO=$2
NAME=$3
VERSION=$4
SECTION=$5
FILE=$6
echo "===> $NAME-$VERSION"
FN="$TMP/$NAME-$VERSION.deb"
$CURL "$REPO/$FILE" -o "$FN" || return
# Get the date from the last modification time of the debian-binary file
# inside the .deb. Preferably, the date we store in the database indicates
# when the *source* package has been uploaded, but this will work fine as
# an approximation, I guess.
DATE=`date -d "\`ar tv \"$FN\" debian-binary | perl -lne 's/^[^ ]+ [^ ]+ +\d+ (.+) debian-binary$/print $1/e'\`" "+%F"`
# Insert package in the database
PKGID=`echo "INSERT INTO package (system, category, name, version, released) VALUES(:'sysid',:'cat',:'name',:'ver',:'rel') RETURNING id"\
| $PSQL -v "sysid=$SYSID" -v "cat=$SECTION" -v "name=$NAME" -v "ver=$VERSION" -v "rel=$DATE"`
# Extract and handle the man pages
if [ "$?" -eq 0 -a -n "$PKGID" ]; then
ar p "$FN" data.tar.gz | ./add_tar.sh - $PKGID -z
fi
rm "$FN"
}
syncrepo() {
SYSID=$1
REPO=$2
DISTRO=$3
COMPONENTS=$4
CONTENTSURL=${5:-"dists/$DISTRO/Contents-i386.gz"}
echo "============ $REPO $DISTRO ($COMPONENTS)"
# Get Contents.gz and Packages
CFN="$TMP/Contents"
PFN="$TMP/Packages"
printf "" >"$PFN"
$CURL "$REPO/$CONTENTSURL" -o "$CFN.gz" || return 1
gunzip "$CFN.gz"
for CMP in $COMPONENTS; do
echo "MANDIFF-COMPONENT: $CMP" >>"$PFN"
TFN="$TMP/Packages-$CMP.bz2"
$CURL "$REPO/dists/$DISTRO/$CMP/binary-i386/Packages.bz2" -o "$TFN" || return 1
bzcat "$TFN" >>"$PFN"
rm "$TFN"
done
# Parse the Contents and Packages files and check with the database to figure
# out which packages we need to download.
mkfifo "$TMP/fifo"
perl -l - $CFN $PFN $SYSID <<'EOP' >"$TMP/fifo" &
($cfn, $pfn, $sysid) = @ARGV;
use DBI;
$db = DBI->connect('dbi:Pg:dbname=manned', 'manned', '', {RaiseError => 1});
open F, '<', $cfn or die $!;
while(<F>) {
chomp; @l=split/ +/;
grep{ s{^.+/([^/]+)$}{$1}; $_ ne"-" and ($pkg{$_}=1) } split/,/, $l[1] if $l[0]=~/\/man\//
}
close F;
open F, '<', $pfn or die $!;
while(<F>) {
chomp;
$p = $1 if /^Package: (.+)/;
$v = $1 if /^Version: (.+)/;
$s = $1 if /^Section: (.+)/;
$f = $1 if /^Filename: (.+)/;
if(!$_) {
if($p && $v && $s && $f) {
print "$p $v $s $f" if $pkg{$p} && $pkg{$p} == 1
&& !$db->selectrow_arrayref(q{SELECT 1 FROM package WHERE system = ? AND name = ? AND version = ?}, {}, $sysid, $p, $v);
warn "Duplicate package? $p\n" if $pkg{$p} && $pkg{$p} == 2;
$pkg{$p} = 2;
}
$p=$v=$f=undef
}
}
close F;
EOP
while read l; do
checkpkg $SYSID $REPO $l
done <"$TMP/fifo"
rm -f "$TMP/fifo" "$CFN" "$PFN"
}
# TODO: backports?
#syncrepo 2 "http://old-releases.ubuntu.com/ubuntu/" "warty" "main multiverse restricted universe"
#syncrepo 2 "http://old-releases.ubuntu.com/ubuntu/" "warty-updates" "main multiverse restricted universe" "dists/warty/Contents-i386.gz"
#syncrepo 2 "http://old-releases.ubuntu.com/ubuntu/" "warty-security" "main multiverse restricted universe" "dists/warty/Contents-i386.gz"
#syncrepo 3 "http://old-releases.ubuntu.com/ubuntu/" "hoary" "main multiverse restricted universe"
#syncrepo 3 "http://old-releases.ubuntu.com/ubuntu/" "hoary-updates" "main multiverse restricted universe" "dists/hoary/Contents-i386.gz"
#syncrepo 3 "http://old-releases.ubuntu.com/ubuntu/" "hoary-security" "main multiverse restricted universe" "dists/hoary/Contents-i386.gz"
#syncrepo 4 "http://old-releases.ubuntu.com/ubuntu/" "breezy" "main multiverse restricted universe"
#syncrepo 4 "http://old-releases.ubuntu.com/ubuntu/" "breezy-updates" "main multiverse restricted universe" "dists/breezy/Contents-i386.gz"
#syncrepo 4 "http://old-releases.ubuntu.com/ubuntu/" "breezy-security" "main multiverse restricted universe" "dists/breezy/Contents-i386.gz"
rm -rf "$TMP"

462
www/index.pl Executable file
View file

@ -0,0 +1,462 @@
#!/usr/bin/perl
use strict;
use warnings;
use TUWF ':html', 'html_escape';
use IPC::Open2;
use IO::Select;
use Encode 'encode_utf8', 'decode_utf8';
use Time::HiRes 'tv_interval', 'gettimeofday';
use Cwd 'abs_path';
our $ROOT;
BEGIN { ($ROOT = abs_path $0) =~ s{/www/index\.pl$}{}; }
use lib "$ROOT/lib/GrottyParser/inst/lib/perl5";
use GrottyParser;
TUWF::set(
logfile => $ENV{TUWF_LOG},
db_login => [undef, undef, undef],
debug => 1,
xml_pretty => 2,
);
TUWF::register(
qr// => \&home,
qr{browse/([^/]+)} => \&browsesys,
qr{browse/([^/]+)/([^/]+)} => \&browsepkg,
qr{([^/]+)/([0-9a-f]{8})} => \&man,
qr{([^/]+)/([0-9a-f]{8})/src} => \&src,
qr{([^/]+)} => \&man,
);
TUWF::run();
sub home {
my $self = shift;
my $sys = $self->dbSystemGet;
$self->htmlHeader(title => 'Man Pages Archive');
h1 'Man Pages Archive';
p 'Welcome blah mission etc.';
h2 'What do you index?';
p 'System and repos etc.';
h2 'Browse!';
ul;
for(@$sys) {
li;
a href => "/browse/$_->{short}", $_->{release} ? "$_->{name} $_->{release}" : $_->{name};
end;
}
end;
h2 'Will you do ...?';
p 'This page looks more like FAQ than a front page... hmmm.';
h2 'Stats?';
p 'Stats are always nice!';
h2 'Other sites';
p '<insert some links here>';
$self->htmlFooter;
}
sub browsesys {
my($self, $short) = @_;
my $sys = $self->dbSystemGet($short)->[0];
return $self->resNotFound if !$sys;
my $chr = $ENV{QUERY_STRING} ? $ENV{QUERY_STRING} : $ENV{QUERY_STRING} eq '' ? 'a' : '0';
return $self->resNotFound if $chr !~ /^[0a-z]$/;
my $pkg = $self->dbPackageList($sys->{id}, $chr);
my $title = "Packages for $sys->{name}".($sys->{release}?" $sys->{release}":"");
$self->htmlHeader(title => $title);
h1 $title;
p;
for(0, 'a'..'z') {
a href => "/browse/$short?$_", $_?$_:'#' if $_ ne $chr;
b $_?$_:'#' if $_ eq $chr;
}
end;
p 'Note: Packages without man pages are not listed.';
ul;
for(@$pkg) {
li;
a href => "/browse/$short/$_->{name}", $_->{name};
i $_->{category};
end;
}
end;
$self->htmlFooter;
}
sub browsepkg {
my($self, $short, $name) = @_;
my $sys = $self->dbSystemGet($short)->[0];
return $self->resNotFound if !$sys;
my $pkgs = $self->dbPackageGet($sys->{id}, $name);
return $self->resNotFound if !@$pkgs;
my $title = "$sys->{name}".($sys->{release}?" $sys->{release}":"")." / $name";
$self->htmlHeader(title => $title);
h1 $title;
#TODO: Link back to the system browsing page
#TODO: Have a menu/index listing the versions of this package? (With links to the anchors)
#TODO: Collapse the man page list by default for older versions if the page becomes too long?
for my $pkg (@$pkgs) {
h2;
a name => $pkg->{version}, href => "#$pkg->{version}", "$pkg->{category} / $pkg->{name} $pkg->{version} ($pkg->{released})";
end;
my $mans = $self->dbManInfo(package => $pkg->{id});
# This can be a table as well.
ul;
# TODO: Put this sort in the SQL query
for(sort { $a->{name}."\x09".($a->{locale}||'') cmp $b->{name}."\x09".($b->{locale}||'') } @$mans) {
li;
a href => "/$_->{name}/".substr($_->{hash},0,8), "$_->{name}($_->{section})";
b " $_->{locale}" if $_->{locale};
i " $_->{filename}";
end;
}
end;
}
$self->htmlFooter;
}
sub manselect {
my($self, $lst, $selhash) = @_;
return if !@$lst;
$selhash ||= '';
my %sys;
push @{$sys{$_->{system}}}, $_ for (@$lst);
dl id => 'nav';
for my $sys (sort keys %sys) {
my %pkgs;
push @{$pkgs{"$_->{package}-$_->{version}"}}, $_ for @{$sys{$sys}};
dt $sys;
dd;
# TODO: This package sorting sucks. Versions should be date-sorted, in descending order.
for my $pkg (sort keys %pkgs) {
dl;
dt $pkg;
dd;
for my $man (sort { $a->{section} cmp $b->{section} } @{$pkgs{$pkg}}) {
my $t = $man->{locale} ? "$man->{section}.$man->{locale}" : $man->{section};
a href => sprintf('/%s/%s', $man->{name}, substr $man->{hash}, 0, 8), $t if $selhash ne $man->{hash};
b $t if $selhash eq $man->{hash};
txt ' ';
}
end;
end;
}
end 'dd';
}
end 'dl';
}
# TODO: Store/cache the result of this of this function in the database.
sub manfmt {
my $c = shift;
# tix comes with[1] a custom(?) macro package. But it looks okay even without
# loading that.
# [1] It actually doesn't, the tcllib package appears to have that file, but
# doesn't '.so' it.
$c =~ s/^\.so man.macros$//mg;
# Other .so's should be handled by the web interface
$c =~ s/^\.so (.+)$/\[\[\[MANDIFF-INCLUDE $1\]\]\]/mg;
# Disable hyphenation, since that screws up man page references. :-(
$c = ".hy 0\n.de hy\n..\n$c";
# Call grog to figure out which preprocessors to use.
# $MANWIDTH works by using the following groff options: -rLL=100n -rLT=100n
my($out, $in);
my $pid = open2($out, $in, qw|grog -Tutf8 -P-c -DUTF-8 -|);
binmode $in, ':utf8';
print $in $c;
close($in);
chomp(my $grog = <$out>);
waitpid $pid, 0;
# Call groff
$pid = open2($out, $in, split / /, $grog);
$c = encode_utf8($c);
my $ret;
# Read/write the data in chunks to avoid a deadlock on large I/O
while($c) {
my @a = IO::Select::select(IO::Select->new($out), IO::Select->new($in), undef);
die "IO::Select failed: $!\n" if !@a;
if(@{$a[0]}) {
my $b;
my $r = sysread($out, $b, 4096);
die "sysread failed: $!\n" if $r < 0;
$ret .= $b if $r;
}
if(@{$a[1]}) {
my $w = syswrite($in, $c, 4096);
die "syswrite failed: $!\n" if $w <= 0;
$c = substr($c, $w);
}
}
close($in);
local $/;
$ret .= <$out>; # Now I'm mixing sysread and buffered read. I don't suppose that is an issue in this case, though.
waitpid $pid, 0;
$ret = decode_utf8($ret);
return $ret;
}
sub manhtml {
my $t0 = [gettimeofday];
my $d = GrottyParser::html(shift);
warn sprintf "manhtml took %fms\n", tv_interval($t0)*1000;
return $d;
}
# Given the name and optionally the section or hash of a man page, check with a
# list of man pages with the same name to select the right hash for display.
sub gethash {
my($name, $sect, $hash, $list) = @_;
# If we already have a shorthash, just get the full hash
if($hash) {
$_->{hash} =~ /^$hash/ && return $_->{hash} for (@$list);
}
# If that failed, sort the list based on some heuristics.
my @l = sort {
# English or non-locale packages always win
!(($a->{locale}||'') =~ /^(en|$)/) != !(($b->{locale}||'') =~ /^(en|$)/)
? (($a->{locale}||'') =~ /^(en|$)/ ? -1 : 1)
# Newer versions of a package have higher priority
: $a->{sysid} == $b->{sysid} && $a->{package} eq $b->{package} && $a->{version} ne $b->{version}
? $b->{released} cmp $a->{released}
# Section prefix match.
: $sect && !($a->{section} =~ /^\Q$sect/) != !($b->{section} =~ /^\Q$sect/)
? ($a->{section} =~ /^\Q$sect/ ? -1 : 1)
# Give lower priority to pages in a non-standard directory
: !($a->{filename} =~ q{^/usr/share/man}) != !($b->{filename} =~ q{^/usr/share/man})
? ($a->{filename} =~ q{^/usr/share/man} ? -1 : 1)
# Lower sections > higher sections (because 'man' does this as well)
: substr($a->{section},0,1) ne substr($b->{section},0,1)
? $a->{section} cmp $b->{section}
# Prefer Arch over other systems
: $a->{sysid} != $b->{sysid}
? ($a->{sysid} == 1 ? -1 : 1)
# Sections without appendix before sections with appendix
: $a->{section} ne $b->{section}
? $a->{section} cmp $b->{section}
# Fallback to hash if nothing else matters (guarantees the order is at least stable)
: $a->{hash} cmp $b->{hash};
} @$list;
return $l[0]{hash};
}
sub man {
my($self, $name, $hash) = @_;
my $sect = $name =~ s/\.([0-9n])$// ? $1 : undef;
my $m = $self->dbManInfo(name => $name);
return $self->resNotFound() if !@$m;
$hash = gethash($name, $sect, $hash, $m);
$self->htmlHeader(title => $name);
manselect $self, $m, $hash;
h1 $name;
p;
txt $hash;
txt ' - ';
a href => "/$name/".substr($hash, 0, 8), 'permalink';
txt ' - ';
a href => "/$name/".substr($hash, 0, 8).'/src', 'source';
end;
div id => 'locations';
h2 'Locations of this man page';
table;
thead; Tr;
td 'System';
td 'Package';
td 'Version';
td 'Name';
td 'Filename';
end; end;
my $l = $self->dbManInfo(hash => $hash);
for(@$l) {
Tr;
td $_->{system};
td "$_->{category}/$_->{package}";
td $_->{version};
td;
a href => "/$_->{name}", $_->{name} if $_->{name} ne $name;
txt $_->{name} if $_->{name} eq $name;
txt ".$_->{section}";
end;
td $_->{filename};
end;
}
end;
end;
div id => 'contents';
h2 'Contents';
my $c = $self->dbManContent($hash);
pre; lit manhtml manfmt $c; end;
end;
$self->htmlFooter;
}
sub src {
my($self, $name, $hash) = @_;
my $m = $self->dbManInfo(name => $name, shorthash => $hash);
return $self->resNotFound if !@$m;
$self->resHeader('Content-Type', 'text/plain; charset=UTF-8');
my $c = $self->dbManContent($m->[0]{hash});
lit $c;
}
package TUWF::Object;
use TUWF ':html', 'html_escape';
sub htmlHeader {
my $self = shift;
my %o = @_;
html;
head;
Link rel => 'stylesheet', type => 'text/css', href => '/man.css';
style type => 'text/css';
lit 'thead tr { font-weight: bold; border-bottom: 1px solid #ccc }';
lit 'table td { border-left: 1px solid #ccc; padding: 0 3px }';
lit 'table { border-collapse: collapse }';
end;
title $o{title}.' - manned.org';
end 'head';
body;
div id => 'header';
a href => '/', 'manned.org';
form;
input type => 'text', name => 'q';
input type => 'submit', value => 'Search';
end;
end;
}
sub htmlFooter {
div id => 'footer';
lit '2012 manned.org';
end;
end 'body';
end 'html';
}
sub dbManContent {
my($s, $hash) = @_;
return $s->dbRow(q{SELECT content FROM contents WHERE hash = decode(?, 'hex')}, $hash)->{content};
}
# Options: name, section, shorthash, locale, package
sub dbManInfo {
my $s = shift;
my %o = @_;
# TODO: Option to only fetch the latest version of a package?
my %where = (
$o{name} ? ('m.name = ?' => $o{name}) : (),
$o{package} ? ('m.package = ?' => $o{package}) : (),
$o{section} ? ('m.section = ?' => $o{section}) : (),
$o{shorthash} ? (q{substring(m.hash from 1 for 4) = decode(?, 'hex')} => $o{shorthash}) : (),
$o{hash} ? (q{m.hash = decode(?, 'hex')} => $o{hash}) : (),
$o{locale} ? ('m.locale = ?', $o{locale}) : exists $o{locale} ? ('m.locale IS NULL' => 1) : (),
);
# TODO: Flags to indicate what to information to fetch
return $s->dbAll(q{
SELECT s.id AS sysid, s.name||' '||COALESCE(s.release, '') AS system, p.category, p.name AS package, p.version, p.released, m.name, m.section, m.filename, m.locale, encode(m.hash, 'hex') AS hash
FROM package p
JOIN man m ON m.package = p.id
JOIN systems s ON s.id = p.system
!W
}, \%where);
}
sub dbSystemGet {
my($s, $short) = @_;
return $s->dbAll(
'SELECT id, name, release, short FROM systems !W ORDER BY name, relorder',
$short ? {'short = ?' => $short } : {}
);
}
sub dbPackageList {
my($s, $sysid, $char) = @_;
my @where = (
'system = ?' => $sysid,
'EXISTS(SELECT 1 FROM man m WHERE m.package = p.id)' => 1,
$char ? ( 'LOWER(SUBSTR(name, 1, 1)) = ?' => $char ) : (),
defined($char) && !$char ? ( '(ASCII(name) < 97 OR ASCII(name) > 122) AND (ASCII(name) < 65 OR ASCII(name) > 90)' => 1 ) : (),
);
# TODO: Optimize this one
return $s->dbAll(q{
SELECT DISTINCT name, category
FROM package p
!W
ORDER BY name},
\@where)
}
sub dbPackageGet {
my($s, $sysid, $name) = @_;
return $s->dbAll(q{
SELECT id, category, name, version, released
FROM package p
WHERE system = ?
AND name = ?
AND EXISTS(SELECT 1 FROM man m WHERE m.package = p.id)
ORDER BY released DESC},
$sysid, $name)
}

40
www/man.css Normal file
View file

@ -0,0 +1,40 @@
* { margin: 0; padding: 0; font-family: Trebuchet MS, sans-serif; }
html { background: #333; padding: 0 10px; }
body { margin: 20px auto; max-width: 1250px; background: #fff; padding: 10px; -webkit-border-radius: 10px; -moz-border-radius: 10px;
-webkit-box-shadow: 0 10px 10px #def; }
h1 { font-size: 24px; font-weight: normal; color: #abc; }
h1 + p { float: right; }
h2 { font-size: 21px; margin-top: 40px; color: #468; font-weight: normal; }
h2 + i { font-size: 12px; }
dd { margin-left: 20px; }
a { color: #048; font-family: Verdana; font-weight: normal; text-decoration: underline; padding: 3px 5px;
-webkit-border-radius: 4px; -moz-border-radius: 4px; }
a:hover { text-decoration: none; background: #cde; }
table { background: #eee; border: 5px solid #f8f8f8; margin: 10px 0; }
td { padding: 1px 5px; font-size: 12px; }
#header { padding: 4px 20px; background: -webkit-linear-gradient(#40556a, #b0c5da); margin: -10px -10px 20px -10px; -webkit-border-radius: 8px 8px 0 0; -webkit-border-radius: 8px 8px 0 0;
border-bottom: 1px solid #888; font: 24px Arial; }
#header a { color: #f8f8f8; text-decoration: none; font-weight: bold; }
#header a:hover { background: none; }
#header form { float: right; }
#header input { -webkit-box-shadow: 1px 1px 3px #fff, -1px -1px 2px #234; }
#header input[type=text] { width: 260px; padding: 2px; border: 1px solid #444; border-radius: 12px 0 0 12px;
background: -webkit-gradient(linear, left top, left bottom, from(#89a), to(white), color-stop(.9, #cde)); padding-left: 15px; }
#header input[type=text]:hover, #header input[type=text]:focus { background: -webkit-linear-gradient(#abc, #f0f8ff); outline: none; }
#header input[type=submit] { padding: 2px 8px; border: 1px solid #444; border-radius: 0 12px 12px 0; color: #EEE; padding-right: 12px;
margin-left: -5px; cursor: pointer; background: -webkit-gradient(linear, left top, left bottom, from(#556), to(#223)); }
#nav { background: #f0f8ff; color: #036; float: right; padding: 8px; -webkit-border-radius: 8px; -moz-border-radius: 8px; width: 250px; margin-bottom: 10px; }
#nav > dt { font-weight: bold; }
#nav a { font-size: 13px; }
#nav b { font-family: Verdana; font-size: 13px; background: #cde; padding: 3px 5px;
-webkit-border-radius: 4px; -moz-border-radius: 4px; }
#footer { height: 60px; clear: both; padding: 4px 10px; color: #f8f8f8; background: -webkit-linear-gradient(#b0c5da, #40556a); margin: 10px -10px -20px -10px; -webkit-border-radius: 0 0 8px 8px; -moz-border-radius: 0 0 8px 8px;
border-top: 1px solid #888; }
pre, pre * { font-family: Lucida Console, Monospace; }
pre b { color: #369; font-weight: normal; }
pre a { padding: 0; font-weight: normal; }
pre a:hover { background: none; text-decoration: underline; color: #48B;}