diff options
| -rw-r--r-- | Makefile.am | 3 | ||||
| -rw-r--r-- | guix/man-db.scm | 200 | ||||
| -rw-r--r-- | guix/profiles.scm | 110 |
3 files changed, 252 insertions, 61 deletions
diff --git a/Makefile.am b/Makefile.am index 85b9ab36d2..fe1e685f34 100644 --- a/Makefile.am +++ b/Makefile.am @@ -34,7 +34,8 @@ nodist_noinst_SCRIPTS = \ # Modules that are not compiled but are installed nonetheless, such as # build-side modules with unusual dependencies. -MODULES_NOT_COMPILED = +MODULES_NOT_COMPILED = \ + guix/man-db.scm include gnu/local.mk diff --git a/guix/man-db.scm b/guix/man-db.scm new file mode 100644 index 0000000000..ae960e5a1e --- /dev/null +++ b/guix/man-db.scm @@ -0,0 +1,200 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix man-db) + #:use-module (guix zlib) + #:use-module ((guix build utils) #:select (find-files)) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:export (mandb-entry? + mandb-entry-file-name + mandb-entry-name + mandb-entry-section + mandb-entry-synopsis + mandb-entry-kind + + mandb-entries + write-mandb-database)) + +;;; Comment: +;;; +;;; Scan gzipped man pages and create a man-db database. The database is +;;; meant to be used by 'man -k KEYWORD'. +;;; +;;; The implementation here aims to be simpler than that of 'man-db', and to +;;; produce deterministic output. See <https://bugs.gnu.org/29654>. +;;; +;;; Code: + +;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co. +(module-use! (current-module) (resolve-interface '(gdbm))) + +(define-record-type <mandb-entry> + (mandb-entry file-name name section synopsis kind) + mandb-entry? + (file-name mandb-entry-file-name) ;e.g., "../abiword.1.gz" + (name mandb-entry-name) ;e.g., "ABIWORD" + (section mandb-entry-section) ;number + (synopsis mandb-entry-synopsis) ;string + (kind mandb-entry-kind)) ;'ultimate | 'link + +(define (mandb-entry<? entry1 entry2) + (match entry1 + (($ <mandb-entry> file1 name1 section1) + (match entry2 + (($ <mandb-entry> file2 name2 section2) + (or (< section1 section2) + (string<? (basename file1) (basename file2)))))))) + +(define abbreviate-file-name + (let ((man-file-rx (make-regexp "(.+)\\.[0-9][a-z]?(\\.gz)?$"))) + (lambda (file) + (match (regexp-exec man-file-rx (basename file)) + (#f + (basename file)) + (matches + (match:substring matches 1)))))) + +(define (entry->string entry) + "Return the wire format for ENTRY as a string." + (match entry + (($ <mandb-entry> file name section synopsis kind) + ;; See db_store.c:make_content in man-db for the format. + (string-append (abbreviate-file-name file) "\t" + (number->string section) "\t" + (number->string section) + + ;; Timestamp that we always set to the epoch. + "\t0\t0" + + ;; See "db_storage.h" in man-db for the different kinds. + "\t" + (case kind + ((ultimate) "A") ;ultimate man page + ((link) "B") ;".so" link to other man page + (else "A")) ;something that doesn't matter much + + "\t-\t-\t" + + (if (string-suffix? ".gz" file) "gz" "") + "\t" + + synopsis "\x00")))) + +;; The man-db schema version we're compatible with. +(define %version-key "$version$\x00") +(define %version-value "2.5.0\x00") + +(define (write-mandb-database file entries) + "Write ENTRIES to FILE as a man-db database. FILE is usually +\".../index.db\", and is a GDBM database." + (let ((db (gdbm-open file GDBM_WRCREAT))) + (gdbm-set! db %version-key %version-value) + + ;; Write ENTRIES in sorted order so we get deterministic output. + (for-each (lambda (entry) + (gdbm-set! db + (string-append (mandb-entry-file-name entry) + "\x00") + (entry->string entry))) + (sort entries mandb-entry<?)) + (gdbm-close db))) + +(define (read-synopsis port) + "Read from PORT a man page synopsis." + (define (section? line) + ;; True if LINE starts with ".SH", ".PP", or so. + (string-prefix? "." (string-trim line))) + + (define (extract-synopsis str) + (match (string-contains str "\\-") + (#f "") + (index + (string-map (match-lambda + (#\newline #\space) + (chr chr)) + (string-trim-both (string-drop str (+ 2 index))))))) + + ;; Synopses look like "Command \- Do something.", possibly spanning several + ;; lines. + (let loop ((lines '())) + (match (read-line port 'concat) + ((? eof-object?) + (extract-synopsis (string-concatenate-reverse lines))) + ((? section?) + (extract-synopsis (string-concatenate-reverse lines))) + (line + (loop (cons line lines)))))) + +(define* (man-page->entry file #:optional (resolve identity)) + "Parse FILE, a gzipped man page, and return a <mandb-entry> for it." + (define (string->number* str) + (if (and (string-prefix? "\"" str) + (> (string-length str) 1) + (string-suffix? "\"" str)) + (string->number (string-drop (string-drop-right str 1) 1)) + (string->number str))) + + ;; Note: This works for both gzipped and uncompressed files. + (call-with-gzip-input-port (open-file file "r0") + (lambda (port) + (let loop ((name #f) + (section #f) + (synopsis #f) + (kind 'ultimate)) + (if (and name section synopsis) + (mandb-entry file name section synopsis kind) + (let ((line (read-line port))) + (if (eof-object? line) + (mandb-entry file name (or section 0) (or synopsis "") + kind) + (match (string-tokenize line) + ((".TH" name (= string->number* section) _ ...) + (loop name section synopsis kind)) + ((".SH" (or "NAME" "\"NAME\"")) + (loop name section (read-synopsis port) kind)) + ((".so" link) + (match (and=> (resolve link) + (cut man-page->entry <> resolve)) + (#f + (loop name section synopsis 'link)) + (alias + (mandb-entry file + (mandb-entry-name alias) + (mandb-entry-section alias) + (mandb-entry-synopsis alias) + 'link)))) + (_ + (loop name section synopsis kind)))))))))) + +(define (man-files directory) + "Return the list of man pages found under DIRECTORY, recursively." + (find-files directory "\\.[0-9][a-z]?(\\.gz)?$")) + +(define (mandb-entries directory) + "Return mandb entries for the man pages found under DIRECTORY, recursively." + (map (lambda (file) + (man-page->entry file + (lambda (link) + (let ((file (string-append directory "/" link + ".gz"))) + (and (file-exists? file) file))))) + (man-files directory))) diff --git a/guix/profiles.scm b/guix/profiles.scm index cedf9faa82..3c05543bec 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -33,6 +33,7 @@ #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix gexp) + #:use-module (guix modules) #:use-module (guix monads) #:use-module (guix store) #:use-module (guix sets) @@ -1113,84 +1114,73 @@ files for the fonts of the @var{manifest} entries." (define (manual-database manifest) "Return a derivation that builds the manual page database (\"mandb\") for the entries in MANIFEST." - (define man-db ;lazy reference - (module-ref (resolve-interface '(gnu packages man)) 'man-db)) + (define gdbm-ffi + (module-ref (resolve-interface '(gnu packages guile)) + 'guile-gdbm-ffi)) + + (define zlib + (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%libz)) + + (define %libz + #+(file-append zlib "/lib/libz"))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure `((guix build utils) + (guix man-db)))))) (define build - (with-imported-modules '((guix build utils)) + (with-imported-modules modules #~(begin - (use-modules (guix build utils) + (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/" + (effective-version))) + + (use-modules (guix man-db) + (guix build utils) (srfi srfi-1) - (srfi srfi-19) - (srfi srfi-26)) + (srfi srfi-19)) - (define entries - (filter-map (lambda (directory) + (define (compute-entries) + (append-map (lambda (directory) (let ((man (string-append directory "/share/man"))) - (and (directory-exists? man) - man))) + (if (directory-exists? man) + (mandb-entries man) + '()))) '#$(manifest-inputs manifest))) - (define manpages-collection-dir - (string-append (getenv "PWD") "/manpages-collection")) - (define man-directory (string-append #$output "/share/man")) - (define (get-manpage-tail-path manpage-path) - (let ((index (string-contains manpage-path "/share/man/"))) - (unless index - (error "Manual path doesn't contain \"/share/man/\":" - manpage-path)) - (string-drop manpage-path (+ index (string-length "/share/man/"))))) - - (define (populate-manpages-collection-dir entries) - (let ((manpages (append-map (cut find-files <> #:stat stat) entries))) - (for-each (lambda (manpage) - (let* ((dest-file (string-append - manpages-collection-dir "/" - (get-manpage-tail-path manpage)))) - (mkdir-p (dirname dest-file)) - (catch 'system-error - (lambda () - (symlink manpage dest-file)) - (lambda args - ;; Different packages may contain the same - ;; manpage. Simply ignore the symlink error. - #t)))) - manpages))) - - (mkdir-p manpages-collection-dir) - (populate-manpages-collection-dir entries) - - ;; Create a mandb config file which contains a custom made - ;; manpath. The associated catpath is the location where the database - ;; gets generated. - (copy-file #+(file-append man-db "/etc/man_db.conf") - "man_db.conf") - (substitute* "man_db.conf" - (("MANDB_MAP /usr/man /var/cache/man/fsstnd") - (string-append "MANDB_MAP " manpages-collection-dir " " - man-directory))) - (mkdir-p man-directory) - (setenv "MANPATH" (string-join entries ":")) - (format #t "Creating manual page database for ~a packages... " - (length entries)) + (format #t "Creating manual page database...~%") (force-output) - (let* ((start-time (current-time)) - (exit-status (system* #+(file-append man-db "/bin/mandb") - "--quiet" "--create" - "-C" "man_db.conf")) - (duration (time-difference (current-time) start-time))) - (format #t "done in ~,3f s~%" + (let* ((start (current-time)) + (entries (compute-entries)) + (_ (write-mandb-database (string-append man-directory + "/index.db") + entries)) + (duration (time-difference (current-time) start))) + (format #t "~a entries processed in ~,1f s~%" + (length entries) (+ (time-second duration) (* (time-nanosecond duration) (expt 10 -9)))) - (force-output) - (zero? exit-status))))) + (force-output))))) (gexp->derivation "manual-database" build + + ;; Work around GDBM 1.13 issue whereby uninitialized bytes + ;; get written to disk: + ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>. + #:env-vars `(("MALLOC_PERTURB_" . "1")) + #:local-build? #t)) (define %default-profile-hooks |