[PATCH 2/2] guix: profiles: create fonts.dir/scale for all fonts directories

[huang_ying_caritas]

From: Huang Ying <address@hidden>

* guix/profiles.scm (fonts-dir-file): Create fonts.dir/scale files for all
  fonts directories.

Suggested-by: 宋文武 <address@hidden>
---
 guix/profiles.scm | 56 ++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 39 insertions(+), 17 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index de82eae34..7c1b552ad 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -879,7 +879,7 @@ entries.  It's used to query the MIME type of a given file."
 
 (define (fonts-dir-file manifest)
   "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale}
-files for the truetype fonts of the @var{manifest} entries."
+files for the fonts of the @var{manifest} entries."
   (define mkfontscale
     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale))
 
@@ -890,30 +890,52 @@ files for the truetype fonts of the @var{manifest} 
entries."
     #~(begin
         (use-modules (srfi srfi-26)
                      (guix build utils)
-                     (guix build union))
-        (let ((ttf-dirs (filter file-exists?
-                                (map (cut string-append <>
-                                          "/share/fonts/truetype")
-                                     '#$(manifest-inputs manifest)))))
+                     (guix build union)
+                     (ice-9 ftw))
+        (let ((fonts-dirs (filter file-exists?
+                                  (map (cut string-append <>
+                                            "/share/fonts")
+                                       '#$(manifest-inputs manifest)))))
           (mkdir #$output)
-          (if (null? ttf-dirs)
+          (if (null? fonts-dirs)
               (exit #t)
-              (let* ((fonts-dir   (string-append #$output "/share/fonts"))
-                     (ttf-dir     (string-append fonts-dir "/truetype"))
+              (let* ((share-dir   (string-append #$output "/share"))
+                     (fonts-dir   (string-append share-dir "/fonts"))
                      (mkfontscale (string-append #+mkfontscale
                                                  "/bin/mkfontscale"))
                      (mkfontdir   (string-append #+mkfontdir
-                                                 "/bin/mkfontdir")))
-                (mkdir-p fonts-dir)
-                (union-build ttf-dir ttf-dirs
-                             #:log-port (%make-void-port "w"))
-                (with-directory-excursion ttf-dir
-                  (exit (and (zero? (system* mkfontscale))
-                             (zero? (system* mkfontdir))))))))))
+                                                 "/bin/mkfontdir"))
+                     (empty-file? (lambda (filename)
+                                    (call-with-ascii-input-file filename
+                                      (lambda (p)
+                                        (eqv? #\0 (read-char p))))))
+                     (fonts-dir-file "fonts.dir")
+                     (fonts-scale-file "fonts.scale"))
+                (mkdir-p share-dir)
+                (union-build fonts-dir fonts-dirs
+                             #:log-port (%make-void-port "w")
+                             #:create-all-directory? #t)
+                (ftw fonts-dir
+                     (lambda (dir statinfo flag)
+                       (and (eq? flag 'directory)
+                            (with-directory-excursion dir
+                              (and (file-exists? fonts-scale-file)
+                                   (delete-file fonts-scale-file))
+                              (and (file-exists? fonts-dir-file)
+                                   (delete-file fonts-dir-file))
+                              (system* mkfontscale)
+                              (system* mkfontdir)
+                              (and (empty-file? fonts-scale-file)
+                                   (delete-file fonts-scale-file))
+                              (and (empty-file? fonts-dir-file)
+                                   (delete-file fonts-dir-file))))
+                       #t)))))))
 
   (gexp->derivation "fonts-dir" build
                     #:modules '((guix build utils)
-                                (guix build union))
+                                (guix build union)
+                                (srfi srfi-26)
+                                (ice-9 ftw))
                     #:local-build? #t
                     #:substitutable? #f))
 
-- 
2.11.1