Merge branch 'master' into core-updates

4 files changed, 89 insertions, 28 deletions

diff --git a/guix/build/union.scm b/guix/build/union.scm
index 6640b56523..a2ea72e1f5 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -73,9 +74,12 @@ identical, #f otherwise."
                                   (loop)))))))))))))
 
 (define* (union-build output inputs
-                      #:key (log-port (current-error-port)))
-  "Build in the OUTPUT directory a symlink tree that is the union of all
-the INPUTS."
+                      #:key (log-port (current-error-port))
+                      (create-all-directories? #f))
+  "Build in the OUTPUT directory a symlink tree that is the union of all the
+INPUTS.  As a special case, if CREATE-ALL-DIRECTORIES?, creates the
+subdirectories in the output directory to make sure the caller can modify them
+later."
 
   (define (symlink* input output)
     (format log-port "`~a' ~~> `~a'~%" input output)
@@ -104,8 +108,11 @@ the INPUTS."
   (define (union output inputs)
     (match inputs
       ((input)
-       ;; There's only one input, so just make a link.
-       (symlink* input output))
+       ;; There's only one input, so just make a link unless
+       ;; create-all-directories?.
+       (if (and create-all-directories? (file-is-directory? input))
+           (union-of-directories output inputs)
+           (symlink* input output)))
       (_
        (call-with-values (lambda () (partition file-is-directory? inputs))
          (match-lambda*
diff --git a/guix/profiles.scm b/guix/profiles.scm
index a62a076f64..795c9447fe 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -877,9 +878,12 @@ entries.  It's used to query the MIME type of a given file."
                           #:substitutable? #f)
         (return #f))))
 
+;; Several font packages may install font files into same directory, so
+;; fonts.dir and fonts.scale file should be generated here, instead of in
+;; packages.
 (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))
 
@@ -891,29 +895,54 @@ files for the truetype fonts of the @var{manifest} entries."
         (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)))))
+        (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)
+                ;; Create all sub-directories, because we may create fonts.dir
+                ;; and fonts.scale files in the sub-directories.
+                (union-build fonts-dir fonts-dirs
+                             #:log-port (%make-void-port "w")
+                             #:create-all-directories? #t)
+                (let ((directories (find-files fonts-dir
+                                               (lambda (file stat)
+                                                 (eq? 'directory (stat:type stat)))
+                                               #:directories? #t)))
+                  (for-each (lambda (dir)
+                              (with-directory-excursion dir
+                                (when (file-exists? fonts-scale-file)
+                                  (delete-file fonts-scale-file))
+                                (when (file-exists? fonts-dir-file)
+                                  (delete-file fonts-dir-file))
+                                (unless (and (zero? (system* mkfontscale))
+                                             (zero? (system* mkfontdir)))
+                                  (exit #f))
+                                (when (empty-file? fonts-scale-file)
+                                  (delete-file fonts-scale-file))
+                                (when (empty-file? fonts-dir-file)
+                                  (delete-file fonts-dir-file))))
+                            directories)))))))
 
   (gexp->derivation "fonts-dir" build
                     #:modules '((guix build utils)
-                                (guix build union))
+                                (guix build union)
+                                (srfi srfi-26))
                     #:local-build? #t
                     #:substitutable? #f))
 
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 66c82f0409..811f167067 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -347,10 +348,25 @@ the synopsis")
                     (_ "synopsis should not start with the package name")
                     'synopsis)))
 
+  (define (check-texinfo-markup synopsis)
+    "Check that SYNOPSIS can be parsed as a Texinfo fragment.  If the
+markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
+    (catch #t
+      (lambda () (texi->plain-text synopsis))
+      (lambda (keys . args)
+        (emit-warning package
+                      (_ "Texinfo markup in synopsis is invalid")
+                      'synopsis)
+        #f)))
+
   (define checks
-    (list check-not-empty check-proper-start check-final-period
-          check-start-article check-start-with-package-name
-          check-synopsis-length))
+    (list check-not-empty
+          check-proper-start
+          check-final-period
+          check-start-article
+          check-start-with-package-name
+          check-synopsis-length
+          check-texinfo-markup))
 
   (match (package-synopsis package)
     ((? string? synopsis)
diff --git a/guix/ui.scm b/guix/ui.scm
index 3a0a6501d1..345bf490b2 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -4,7 +4,7 @@
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014 Cyrill Schenkel <cyrill.schenkel@gmail.com>
-;;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2014, 2015, 2017 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
@@ -81,6 +81,7 @@
             fill-paragraph
             texi->plain-text
             package-description-string
+            package-synopsis-string
             string->recutils
             package->recutils
             package-specification->name+version+output
@@ -848,10 +849,18 @@ converted to a space; sequences of more than one line break are preserved."
   (with-fluids ((%default-port-encoding "UTF-8"))
     (stexi->plain-text (texi-fragment->stexi str))))
 
+(define (package-field-string package field-accessor)
+  "Return a plain-text representation of PACKAGE field."
+  (and=> (field-accessor package)
+         (compose texi->plain-text P_)))
+
 (define (package-description-string package)
   "Return a plain-text representation of PACKAGE description field."
-  (and=> (package-description package)
-         (compose texi->plain-text P_)))
+  (package-field-string package package-description))
+
+(define (package-synopsis-string package)
+  "Return a plain-text representation of PACKAGE synopsis field."
+  (package-field-string package package-synopsis))
 
 (define (string->recutils str)
   "Return a version of STR where newlines have been replaced by newlines
@@ -914,7 +923,7 @@ WIDTH columns."
           (string-map (match-lambda
                        (#\newline #\space)
                        (chr       chr))
-                      (or (and=> (package-synopsis p) P_)
+                      (or (and=> (package-synopsis-string p) P_)
                           "")))
   (format port "~a~2%"
           (string->recutils