diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/emacs-build-system.scm | 40 | ||||
| -rw-r--r-- | guix/build/glib-or-gtk-build-system.scm | 28 | ||||
| -rw-r--r-- | guix/build/gnu-build-system.scm | 15 | ||||
| -rw-r--r-- | guix/build/utils.scm | 52 |
4 files changed, 66 insertions, 69 deletions
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index c01b24fe9a..cb5bde3191 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -83,7 +83,8 @@ store in '.el' files." (let* ((out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) (el-dir (string-append out %install-suffix "/" elpa-name-ver)) - (info-dir (string-append out "/share/info")) + (name-ver (strip-store-file-name out)) + (info-dir (string-append out "/share/info/")) (info-files (find-files el-dir "\\.info$"))) (unless (null? info-files) (mkdir-p info-dir) @@ -115,7 +116,7 @@ store in '.el' files." (filter (match-lambda ((label . directory) (emacs-package? ((compose package-name->name+version - store-directory->name-version) + strip-store-file-name) directory))) (_ #f)) inputs)) @@ -137,47 +138,18 @@ DIRS." (define (package-name-version->elpa-name-version name-ver) "Convert the Guix package NAME-VER to the corresponding ELPA name-version format. Essnetially drop the prefix used in Guix." - (let ((name (store-directory->name-version name-ver))) + (let ((name (strip-store-file-name name-ver))) (if (emacs-package? name-ver) - (store-directory->name-version name-ver) + (strip-store-file-name name-ver) name-ver))) (define (store-directory->elpa-name-version store-dir) "Given a store directory STORE-DIR return the part of the basename after the second hyphen. This corresponds to 'name-version' as used in ELPA packages." ((compose package-name-version->elpa-name-version - store-directory->name-version) + strip-store-file-name) store-dir)) -(define (store-directory->name-version store-dir) - "Given a store directory STORE-DIR return the part of the basename -after the first hyphen. This corresponds to 'name-version' of the package." - (let* ((base (basename store-dir))) - (string-drop base - (+ 1 (string-index base #\-))))) - -;; from (guix utils). Should we put it in (guix build utils)? -(define (package-name->name+version name) - "Given NAME, a package name like \"foo-0.9.1b\", return two values: -\"foo\" and \"0.9.1b\". When the version part is unavailable, NAME and -#f are returned. The first hyphen followed by a digit is considered to -introduce the version part." - ;; See also `DrvName' in Nix. - - (define number? - (cut char-set-contains? char-set:digit <>)) - - (let loop ((chars (string->list name)) - (prefix '())) - (match chars - (() - (values name #f)) - ((#\- (? number? n) rest ...) - (values (list->string (reverse prefix)) - (list->string (cons n rest)))) - ((head tail ...) - (loop tail (cons head prefix)))))) - (define %standard-phases (modify-phases gnu:%standard-phases (delete 'configure) diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm index 15d7de2236..b6291e735b 100644 --- a/guix/build/glib-or-gtk-build-system.scm +++ b/guix/build/glib-or-gtk-build-system.scm @@ -213,37 +213,9 @@ if needed." #t)))) outputs)) -(define* (generate-icon-cache #:key outputs #:allow-other-keys) - "Implement phase \"glib-or-gtk-icon-cache\": generate icon cache if -needed." - (every (match-lambda - ((output . directory) - (let ((iconsdir (string-append directory - "/share/icons"))) - (when (file-exists? iconsdir) - (with-directory-excursion iconsdir - (for-each - (lambda (dir) - (unless (file-exists? - (string-append iconsdir "/" dir "/" - "icon-theme.cache")) - (system* "gtk-update-icon-cache" - "--ignore-theme-index" - (string-append iconsdir "/" dir)))) - (scandir "." - (lambda (name) - (and - (not (equal? name ".")) - (not (equal? name "..")) - (equal? 'directory - (stat:type (stat name))))))))) - #t))) - outputs)) - (define %standard-phases (modify-phases gnu:%standard-phases (add-after 'install 'glib-or-gtk-compile-schemas compile-glib-schemas) - (add-after 'install 'glib-or-gtk-icon-cache generate-icon-cache) (add-after 'install 'glib-or-gtk-wrap wrap-all-programs))) (define* (glib-or-gtk-build #:key inputs (phases %standard-phases) diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 102207b022..0a774e1e84 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -25,6 +25,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 format) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (rnrs io ports) #:export (%standard-phases @@ -576,6 +577,11 @@ DOCUMENTATION-COMPRESSOR-FLAGS." #:rest args) "Build from SOURCE to OUTPUTS, using INPUTS, and by running all of PHASES in order. Return #t if all the PHASES succeeded, #f otherwise." + (define (elapsed-time end start) + (let ((diff (time-difference end start))) + (+ (time-second diff) + (/ (time-nanosecond diff) 1e9)))) + (setvbuf (current-output-port) _IOLBF) (setvbuf (current-error-port) _IOLBF) @@ -586,12 +592,13 @@ in order. Return #t if all the PHASES succeeded, #f otherwise." ;; PHASES can pick the keyword arguments it's interested in. (every (match-lambda ((name . proc) - (let ((start (gettimeofday))) + (let ((start (current-time time-monotonic))) (format #t "starting phase `~a'~%" name) (let ((result (apply proc args)) - (end (gettimeofday))) - (format #t "phase `~a' ~:[failed~;succeeded~] after ~a seconds~%" - name result (- (car end) (car start))) + (end (current-time time-monotonic))) + (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" + name result + (elapsed-time end start)) ;; Dump the environment variables as a shell script, for handy debugging. (system "export > $NIX_BUILD_TOP/environment-variables") diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 676a0120e3..971929621a 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +22,7 @@ (define-module (guix build utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-60) #:use-module (ice-9 ftw) #:use-module (ice-9 match) @@ -33,6 +35,8 @@ alist-delete) #:export (%store-directory store-file-name? + strip-store-file-name + package-name->name+version parallel-job-count directory-exists? @@ -43,6 +47,7 @@ ar-file? with-directory-excursion mkdir-p + install-file copy-recursively delete-file-recursively file-name-predicate @@ -86,6 +91,33 @@ "Return true if FILE is in the store." (string-prefix? (%store-directory) file)) +(define (strip-store-file-name file) + "Strip the '/gnu/store' and hash from FILE, a store file name. The result +is typically a \"PACKAGE-VERSION\" string." + (string-drop file + (+ 34 (string-length (%store-directory))))) + +(define (package-name->name+version name) + "Given NAME, a package name like \"foo-0.9.1b\", return two values: +\"foo\" and \"0.9.1b\". When the version part is unavailable, NAME and +#f are returned. The first hyphen followed by a digit is considered to +introduce the version part." + ;; See also `DrvName' in Nix. + + (define number? + (cut char-set-contains? char-set:digit <>)) + + (let loop ((chars (string->list name)) + (prefix '())) + (match chars + (() + (values name #f)) + ((#\- (? number? n) rest ...) + (values (list->string (reverse prefix)) + (list->string (cons n rest)))) + ((head tail ...) + (loop tail (cons head prefix)))))) + (define parallel-job-count ;; Number of processes to be passed next to GNU Make's `-j' argument. (make-parameter @@ -197,6 +229,12 @@ with the bytes in HEADER, a bytevector." (apply throw args)))))) (() #t)))) +(define (install-file file directory) + "Create DIRECTORY if it does not exist and copy FILE in there under the same +name." + (mkdir-p directory) + (copy-file file (string-append directory "/" (basename file)))) + (define* (copy-recursively source destination #:key (log (current-output-port)) @@ -279,13 +317,16 @@ name matches REGEXP." (regexp-exec file-rx (basename file))))) (define* (find-files dir #:optional (pred (const #t)) - #:key (stat lstat)) + #:key (stat lstat) + directories? + fail-on-error?) "Return the lexicographically sorted list of files under DIR for which PRED returns true. PRED is passed two arguments: the absolute file name, and its stat buffer; the default predicate always returns true. PRED can also be a regular expression, in which case it is equivalent to (file-name-predicate PRED). STAT is used to obtain file information; using 'lstat' means that -symlinks are not followed." +symlinks are not followed. If DIRECTORIES? is true, then directories will +also be included. If FAIL-ON-ERROR? is true, raise an exception upon error." (let ((pred (if (procedure? pred) pred (file-name-predicate pred)))) @@ -296,7 +337,10 @@ symlinks are not followed." (cons file result) result)) (lambda (dir stat result) ; down - result) + (if (and directories? + (pred dir stat)) + (cons dir result) + result)) (lambda (dir stat result) ; up result) (lambda (file stat result) ; skip @@ -304,6 +348,8 @@ symlinks are not followed." (lambda (file stat errno result) (format (current-error-port) "find-files: ~a: ~a~%" file (strerror errno)) + (when fail-on-error? + (error "find-files failed")) result) '() dir |