From b8396f96bfeadfa63e7ad2afc2ab5a37f37f5f81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 15 Dec 2017 22:16:18 +0100 Subject: profiles: Use (guix man-db) to create the manual database. Fixes . Reported by Ruud van Asseldonk . 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). --- guix/profiles.scm | 110 +++++++++++++++++++++++++----------------------------- 1 file changed, 50 insertions(+), 60 deletions(-) (limited to 'guix/profiles.scm') 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: + ;; . + #:env-vars `(("MALLOC_PERTURB_" . "1")) + #:local-build? #t)) (define %default-profile-hooks -- cgit v1.2.3