From addce19e2d38a197f5ea10eefb5f3cd25c3a52e7 Mon Sep 17 00:00:00 2001 From: Huang Ying Date: Sun, 12 Mar 2017 19:53:58 +0800 Subject: union: Add create-all-directories? parameter to 'union-build'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build/union.scm (union-build): Add create-all-directories? keyword parameter. * tests/union.scm ("union-build #:create-all-directories? #t"): New test. Co-authored-by: Ludovic Courtès --- guix/build/union.scm | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) (limited to 'guix') 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 ;;; Copyright © 2014 Mark H Weaver +;;; Copyright © 2017 Huang Ying ;;; ;;; 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* -- cgit v1.2.3 From 0a5ce0d1df3befa2c4e018e84da3bd66c9eac48d Mon Sep 17 00:00:00 2001 From: Huang Ying Date: Sun, 12 Mar 2017 19:53:59 +0800 Subject: profiles: Create fonts.dir/scale for all fonts directories. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/profiles.scm (fonts-dir-file): Create fonts.dir/scale files for all fonts directories. Signed-off-by: Ludovic Courtès --- guix/profiles.scm | 61 ++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 45 insertions(+), 16 deletions(-) (limited to 'guix') 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 ;;; Copyright © 2016 Ricardo Wurmus ;;; Copyright © 2016 Chris Marusich +;;; Copyright © 2017 Huang Ying ;;; ;;; 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)) -- cgit v1.2.3 From 689db38e3467f66725e8841eac72225110a75a17 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Mon, 20 Mar 2017 13:41:41 +0300 Subject: ui: Support Texinfo markup in package synopses. * guix/ui.scm (package-field-string): New procedure. (package-description-string): Use it. (package-synopsis-string): New procedure. (package->recutils): Use it. * guix/scripts/lint.scm (check-synopsis-style)[check-texinfo-markup]: New procedure. Use it in checks. * tests/lint.scm: Test it. * gnu/packages/perl.scm (perl-try-tiny)[synopsis]: Adjust for the Texinfo markup. --- gnu/packages/perl.scm | 2 +- guix/scripts/lint.scm | 22 +++++++++++++++++++--- guix/ui.scm | 17 +++++++++++++---- tests/lint.scm | 8 ++++++++ 4 files changed, 41 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/gnu/packages/perl.scm b/gnu/packages/perl.scm index 82c4ef5d17..3470121883 100644 --- a/gnu/packages/perl.scm +++ b/gnu/packages/perl.scm @@ -7684,7 +7684,7 @@ Tree::Simple::Visitor::* objects.") "068vdbpacfawc3lkfs0b82xxl27h3l0gj14iada3vlwk8rps9yv0")))) (build-system perl-build-system) (home-page "http://search.cpan.org/dist/Try-Tiny") - (synopsis "Minimal try/catch with proper preservation of $@") + (synopsis "Minimal try/catch with proper preservation of $@@") (description "This module provides bare bones try/catch/finally statements that are designed to minimize common mistakes with eval blocks, and nothing else.") 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 ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel +;;; Copyright © 2017 Alex Kost ;;; ;;; 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 ;;; Copyright © 2014 Cyril Roelandt ;;; Copyright © 2014 Cyrill Schenkel -;;; Copyright © 2014, 2015 Alex Kost +;;; Copyright © 2014, 2015, 2017 Alex Kost ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Roel Janssen @@ -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 diff --git a/tests/lint.scm b/tests/lint.scm index 3a9b89fe95..7610a91fd3 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Hartmut Goebel +;;; Copyright © 2017 Alex Kost ;;; ;;; This file is part of GNU Guix. ;;; @@ -167,6 +168,13 @@ (check-synopsis-style pkg))) "synopsis should not be empty"))) +(test-assert "synopsis: valid Texinfo markup" + (->bool + (string-contains + (with-warnings + (check-synopsis-style (dummy-package "x" (synopsis "Bad $@ texinfo")))) + "Texinfo markup in synopsis is invalid"))) + (test-assert "synopsis: does not start with an upper-case letter" (->bool (string-contains (with-warnings -- cgit v1.2.3