diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/gnu-build-system.scm | 34 | ||||
| -rw-r--r-- | guix/build/make-bootstrap.scm | 2 | ||||
| -rw-r--r-- | guix/build/perl-build-system.scm | 6 | ||||
| -rw-r--r-- | guix/build/profiles.scm | 24 | ||||
| -rw-r--r-- | guix/build/utils.scm | 44 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 2 | ||||
| -rw-r--r-- | guix/search-paths.scm | 28 |
7 files changed, 112 insertions, 28 deletions
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 1dfd85450c..1786e2e3c9 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -389,15 +389,23 @@ makefiles." debug-output objcopy-command)) (for-each (lambda (file) - (and (file-exists? file) ;discard dangling symlinks - (or (elf-file? file) (ar-file? file)) + (and (or (elf-file? file) (ar-file? file)) (or (not debug-output) (make-debug-file file)) + + ;; Ensure the file is writable. + (begin (make-file-writable file) #t) + (zero? (apply system* strip-command (append strip-flags (list file)))) (or (not debug-output) (add-debug-link file)))) - (find-files dir))) + (find-files dir + (lambda (file stat) + ;; Ignore symlinks such as: + ;; libfoo.so -> libfoo.so.0.0. + (eq? 'regular (stat:type stat))) + #:stat lstat))) (or (not strip-binaries?) (every strip-dir @@ -476,6 +484,23 @@ and 'man/'. This phase moves directories to the right place if needed." (for-each validate-output directories))) #t) +(define* (reset-gzip-timestamps #:key outputs #:allow-other-keys) + "Reset embedded timestamps in gzip files found in OUTPUTS." + (define (process-directory directory) + (let ((files (find-files directory + (lambda (file stat) + (and (eq? 'regular (stat:type stat)) + (or (string-suffix? ".gz" file) + (string-suffix? ".tgz" file)) + (gzip-file? file))) + #:stat lstat))) + (for-each reset-gzip-timestamp files))) + + (match outputs + (((names . directories) ...) + (for-each process-directory directories))) + #t) + (define* (compress-documentation #:key outputs (compress-documentation? #t) (documentation-compressor "gzip") @@ -598,6 +623,7 @@ which cannot be found~%" validate-documentation-location delete-info-dir-file patch-dot-desktop-files + reset-gzip-timestamps compress-documentation))) diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index 21c78cc8f5..43b136248f 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -55,7 +55,7 @@ when producing a bootstrap libc." (string-append incdir "/linux"))) '("limits.h" "errno.h" "socket.h" "kernel.h" "sysctl.h" "param.h" "ioctl.h" "types.h" - "posix_types.h" "stddef.h")) + "posix_types.h" "stddef.h" "falloc.h")) (copy-recursively (string-append kernel-headers "/include/asm") (string-append incdir "/asm")) diff --git a/guix/build/perl-build-system.scm b/guix/build/perl-build-system.scm index 8f480eae16..b2024e4406 100644 --- a/guix/build/perl-build-system.scm +++ b/guix/build/perl-build-system.scm @@ -42,7 +42,11 @@ "--installdirs=site" ,@module-build-flags)) ((file-exists? "Makefile.PL") `("Makefile.PL" ,(string-append "PREFIX=" out) - "INSTALLDIRS=site" ,@make-maker-flags)) + ;; Prevent installation of 'perllocal.pod' files for + ;; determinism. These are typically used to build a + ;; catalogue of installed packages, but does not provide + ;; any useful information when installed with a module. + "INSTALLDIRS=site" "NO_PERLLOCAL=1" ,@make-maker-flags)) (else (error "no Build.PL or Makefile.PL found"))))) (format #t "running `perl' with arguments ~s~%" args) (zero? (apply system* "perl" args)))) diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 6e316d5d2c..42eabfaf19 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,17 +39,21 @@ 'GUIX_PROFILE' environment variable. This allows users to specify what the user-friendly name of the profile is, for instance ~/.guix-profile rather than /gnu/store/...-profile." - (let ((replacement (string-append "${GUIX_PROFILE:-" profile "}"))) + (let ((replacement (string-append "${GUIX_PROFILE:-" profile "}")) + (crop (cute string-drop <> (string-length profile)))) (match-lambda ((search-path . value) - (let* ((separator (search-path-specification-separator search-path)) - (items (string-tokenize* value separator)) - (crop (cute string-drop <> (string-length profile)))) - (cons search-path - (string-join (map (lambda (str) - (string-append replacement (crop str))) - items) - separator))))))) + (match (search-path-specification-separator search-path) + (#f + (cons search-path + (string-append replacement (crop value)))) + ((? string? separator) + (let ((items (string-tokenize* value separator))) + (cons search-path + (string-join (map (lambda (str) + (string-append replacement (crop str))) + items) + separator))))))))) (define (write-environment-variable-definition port) "Write the given environment variable definition to PORT." diff --git a/guix/build/utils.scm b/guix/build/utils.scm index bc6f114152..e8efb0653a 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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> @@ -45,9 +45,12 @@ call-with-ascii-input-file elf-file? ar-file? + gzip-file? + reset-gzip-timestamp with-directory-excursion mkdir-p install-file + make-file-writable copy-recursively delete-file-recursively file-name-predicate @@ -195,6 +198,29 @@ with the bytes in HEADER, a bytevector." (define ar-file? (file-header-match %ar-magic-bytes)) +(define %gzip-magic-bytes + ;; Magic bytes of gzip file. Beware, it's a small header so there could be + ;; false positives. + #vu8(#x1f #x8b)) + +(define gzip-file? + (file-header-match %gzip-magic-bytes)) + +(define* (reset-gzip-timestamp file #:key (keep-mtime? #t)) + "If FILE is a gzip file, reset its embedded timestamp (as with 'gzip +--no-name') and return true. Otherwise return #f. When KEEP-MTIME? is true, +preserve FILE's modification time." + (let ((stat (stat file)) + (port (open file O_RDWR))) + (dynamic-wind + (const #t) + (lambda () + (and (= 4 (seek port 4 SEEK_SET)) + (put-bytevector port #vu8(0 0 0 0)))) + (lambda () + (close-port port) + (set-file-time file stat))))) + (define-syntax-rule (with-directory-excursion dir body ...) "Run BODY with DIR as the process's current directory." (let ((init (getcwd))) @@ -237,6 +263,11 @@ name." (mkdir-p directory) (copy-file file (string-append directory "/" (basename file)))) +(define (make-file-writable file) + "Make FILE writable for its owner." + (let ((stat (lstat file))) ;XXX: symlinks + (chmod file (logior #o600 (stat:perms stat))))) + (define* (copy-recursively source destination #:key (log (current-output-port)) @@ -400,10 +431,17 @@ for under the directories designated by FILES. For example: (delete-duplicates input-dirs))) (define (list->search-path-as-string lst separator) - (string-join lst separator)) + (if separator + (string-join lst separator) + (match lst + ((head rest ...) head) + (() "")))) (define* (search-path-as-string->list path #:optional (separator #\:)) - (string-tokenize path (char-set-complement (char-set separator)))) + (if separator + (string-tokenize path + (char-set-complement (char-set separator))) + (list path))) (define* (set-path-environment-variable env-var files input-dirs #:key diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 9e5b7f3c75..6be9d00aec 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -667,7 +667,7 @@ processed, #f otherwise." (_ #f)) opts) (() (list %current-profile)) - (lst lst))) + (lst (reverse lst)))) (profile (match profiles ((head tail ...) head)))) (match (assoc-ref opts 'query) diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 7a6fe67959..4bf0e44389 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,7 +55,7 @@ search-path-specification? (variable search-path-specification-variable) ;string (files search-path-specification-files) ;list of strings - (separator search-path-specification-separator ;string + (separator search-path-specification-separator ;string | #f (default ":")) (file-type search-path-specification-file-type ;symbol (default 'directory)) @@ -131,11 +131,23 @@ like `string-tokenize', but SEPARATOR is a string." DIRECTORIES, a list of directory names, and return a list of specification/value pairs. Use GETENV to determine the current settings and report only settings not already effective." - (define search-path-definition - (match-lambda - ((and spec - ($ <search-path-specification> variable files separator - type pattern)) + (define (search-path-definition spec) + (match spec + (($ <search-path-specification> variable files #f type pattern) + ;; Separator is #f so return the first match. + (match (with-null-error-port + (search-path-as-list files directories + #:type type + #:pattern pattern)) + (() + #f) + ((head . _) + (let ((value (getenv variable))) + (if (and value (string=? value head)) + #f ;VARIABLE already set appropriately + (cons spec head)))))) + (($ <search-path-specification> variable files separator + type pattern) (let* ((values (or (and=> (getenv variable) (cut string-tokenize* <> separator)) '())) @@ -164,7 +176,7 @@ current value), or 'suffix (return the definition where VALUE is added as a suffix to VARIABLE's current value.) In the case of 'prefix and 'suffix, SEPARATOR is used as the separator between VARIABLE's current value and its prefix/suffix." - (match kind + (match (if (not separator) 'exact kind) ('exact (format #f "export ~a=\"~a\"" variable value)) ('prefix |