aboutsummaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/man-db.scm200
-rw-r--r--guix/profiles.scm110
2 files changed, 250 insertions, 60 deletions
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
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-16 14:35:54 +0000