mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
profiles: Use (guix man-db) to create the manual database.
Fixes <https://bugs.gnu.org/29654>. Reported by Ruud van Asseldonk <dev+guix@veniogames.com>. This also speeds up database creation compared to "man-db --create" (less than half the time, on a warm cache, for 19k pages.) * guix/man-db.scm: New file. * Makefile.am (MODULES_NOT_COMPILED): Add it. * guix/profiles.scm (manual-database): Rewrite to use (guix man-db).
This commit is contained in:
Ludovic Courtès
parent
e25ca462e5
commit
b8396f96bf
3 changed files with 252 additions and 61 deletions
|
|
@ -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
|
||||
|
||||
|
|
|
|||
200
guix/man-db.scm
Normal file
200
guix/man-db.scm
Normal file
|
|
@ -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)))
|
||||
|
|
@ -33,6 +33,7 @@ (define-module (guix profiles)
|
|||
#: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 @@ (define build
|
|||
(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
|
||||
|
|
|
|||
Loading…
Reference in a new issue