Merge branch 'master' into core-updates

1 files changed, 50 insertions, 60 deletions

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 07fe2faa3c..8e3e49e444 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)
@@ -1114,84 +1115,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