diff options
Diffstat (limited to 'guix/build/utils.scm')
| -rw-r--r-- | guix/build/utils.scm | 187 |
1 files changed, 153 insertions, 34 deletions
diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 419c10195b..6c37021673 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,10 +1,12 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015, 2018, 2021 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,9 +51,14 @@ package-name->name+version parallel-job-count + compressor + tarball? + %xz-parallel-args + directory-exists? executable-file? symbolic-link? + call-with-temporary-output-file call-with-ascii-input-file elf-file? ar-file? @@ -134,12 +141,39 @@ ;;; +;;; Compression helpers. +;;; + +(define (compressor file-name) + "Return the name of the compressor package/binary used to compress or +decompress FILE-NAME, based on its file extension, else false." + (cond ((string-suffix? "gz" file-name) "gzip") + ((string-suffix? "Z" file-name) "gzip") + ((string-suffix? "bz2" file-name) "bzip2") + ((string-suffix? "lz" file-name) "lzip") + ((string-suffix? "zip" file-name) "unzip") + ((string-suffix? "xz" file-name) "xz") + (else #f))) ;no compression used/unknown file extension + +(define (tarball? file-name) + "True when FILE-NAME has a tar file extension." + (string-match "\\.(tar(\\..*)?|tgz|tbz)$" file-name)) + +(define (%xz-parallel-args) + "The xz arguments required to enable bit-reproducible, multi-threaded +compression." + (list "--memlimit=50%" + (format #f "--threads=~a" (max 2 (parallel-job-count))))) + + +;;; ;;; Directories. ;;; (define (%store-directory) "Return the directory name of the store." - (or (getenv "NIX_STORE") + (or (getenv "NIX_STORE_DIR") ;outside of builder + (getenv "NIX_STORE") ;inside builder, set by the daemon "/gnu/store")) (define (store-file-name? file) @@ -197,6 +231,22 @@ introduce the version part." "Return #t if FILE is a symbolic link (aka. \"symlink\".)" (eq? (stat:type (lstat file)) 'symlink)) +(define (call-with-temporary-output-file proc) + "Call PROC with a name of a temporary file and open output port to that +file; close the file and delete it when leaving the dynamic extent of this +call." + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/guix-file.XXXXXX")) + (out (mkstemp! template))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc template out)) + (lambda () + (false-if-exception (close out)) + (false-if-exception (delete-file template)))))) + (define (call-with-ascii-input-file file proc) "Open FILE as an ASCII or binary file, and pass the resulting port to PROC. FILE is closed when PROC's dynamic extent is left. Return the @@ -322,11 +372,13 @@ name." #:key (log (current-output-port)) (follow-symlinks? #f) - keep-mtime?) + (copy-file copy-file) + keep-mtime? keep-permissions?) "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS? -is true; otherwise, just preserve them. When KEEP-MTIME? is true, keep the -modification time of the files in SOURCE on those of DESTINATION. Write -verbose output to the LOG port." +is true; otherwise, just preserve them. Call COPY-FILE to copy regular files. +When KEEP-MTIME? is true, keep the modification time of the files in SOURCE on +those of DESTINATION. When KEEP-PERMISSIONS? is true, preserve file +permissions. Write verbose output to the LOG port." (define strip-source (let ((len (string-length source))) (lambda (file) @@ -343,16 +395,21 @@ verbose output to the LOG port." (symlink target dest))) (else (copy-file file dest) - (when keep-mtime? - (set-file-time dest stat)))))) + (when keep-permissions? + (chmod dest (stat:perms stat))))) + (when keep-mtime? + (set-file-time dest stat)))) (lambda (dir stat result) ; down (let ((target (string-append destination (strip-source dir)))) - (mkdir-p target) - (when keep-mtime? - (set-file-time target stat)))) + (mkdir-p target))) (lambda (dir stat result) ; up - result) + (let ((target (string-append destination + (strip-source dir)))) + (when keep-mtime? + (set-file-time target stat)) + (when keep-permissions? + (chmod target (stat:perms stat))))) (const #t) ; skip (lambda (file stat errno result) (format (current-error-port) "i/o error: ~a: ~a~%" @@ -365,6 +422,16 @@ verbose output to the LOG port." stat lstat))) +(define-syntax-rule (warn-on-error expr file) + (catch 'system-error + (lambda () + expr) + (lambda args + (format (current-error-port) + "warning: failed to delete ~a: ~a~%" + file (strerror + (system-error-errno args)))))) + (define* (delete-file-recursively dir #:key follow-mounts?) "Delete DIR recursively, like `rm -rf', without following symlinks. Don't @@ -375,10 +442,10 @@ errors." (or follow-mounts? (= dev (stat:dev stat)))) (lambda (file stat result) ; leaf - (delete-file file)) + (warn-on-error (delete-file file) file)) (const #t) ; down (lambda (dir stat result) ; up - (rmdir dir)) + (warn-on-error (rmdir dir) dir)) (const #t) ; skip (lambda (file stat errno result) (format (current-error-port) @@ -746,6 +813,31 @@ PROC's result is returned." (lambda (key . args) (false-if-exception (delete-file template)))))) +(define (unused-private-use-code-point s) + "Find a code point within a Unicode Private Use Area that is not +present in S, and return the corresponding character object. If one +cannot be found, return false." + (define (scan lo hi) + (and (<= lo hi) + (let ((c (integer->char lo))) + (if (string-index s c) + (scan (+ lo 1) hi) + c)))) + (or (scan #xE000 #xF8FF) + (scan #xF0000 #xFFFFD) + (scan #x100000 #x10FFFD))) + +(define (replace-char c1 c2 s) + "Return a string which is equal to S except with all instances of C1 +replaced by C2. If C1 and C2 are equal, return S." + (if (char=? c1 c2) + s + (string-map (lambda (c) + (if (char=? c c1) + c2 + c)) + s))) + (define (substitute file pattern+procs) "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each line of FILE, and for each PATTERN that it matches, call the corresponding @@ -764,16 +856,26 @@ end of a line; by itself it won't match the terminating newline of a line." (let loop ((line (read-line in 'concat))) (if (eof-object? line) #t - (let ((line (fold (lambda (r+p line) - (match r+p - ((regexp . proc) - (match (list-matches regexp line) - ((and m+ (_ _ ...)) - (proc line m+)) - (_ line))))) - line - rx+proc))) - (display line out) + ;; Work around the fact that Guile's regexp-exec does not handle + ;; NUL characters (a limitation of the underlying GNU libc's + ;; regexec) by temporarily replacing them by an unused private + ;; Unicode code point. + ;; TODO: Use SRFI-115 instead, once available in Guile. + (let* ((nul* (or (and (string-index line #\nul) + (unused-private-use-code-point line)) + #\nul)) + (line* (replace-char #\nul nul* line)) + (line1* (fold (lambda (r+p line) + (match r+p + ((regexp . proc) + (match (list-matches regexp line) + ((and m+ (_ _ ...)) + (proc line m+)) + (_ line))))) + line* + rx+proc)) + (line1 (replace-char nul* #\nul line1*))) + (display line1 out) (loop (read-line in 'concat))))))))) @@ -800,7 +902,7 @@ sub-expression. For example: ((\"hello\") \"good morning\\n\") ((\"foo([a-z]+)bar(.*)$\" all letters end) - (string-append \"baz\" letter end))) + (string-append \"baz\" letters end))) Here, anytime a line of FILE contains \"hello\", it is replaced by \"good morning\". Anytime a line of FILE matches the second regexp, ALL is bound to @@ -853,29 +955,45 @@ match the terminating newline of a line." ;;; (define* (dump-port in out + #:optional len #:key (buffer-size 16384) (progress (lambda (t k) (k)))) - "Read as much data as possible from IN and write it to OUT, using chunks of -BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful -transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes -transferred and the continuation of the transfer as a thunk." + "Read LEN bytes from IN or as much data as possible if LEN is #f, and write +it to OUT, using chunks of BUFFER-SIZE bytes. Call PROGRESS at the beginning +and after each successful transfer of BUFFER-SIZE bytes or less, passing it +the total number of bytes transferred and the continuation of the transfer as +a thunk." (define buffer (make-bytevector buffer-size)) (define (loop total bytes) (or (eof-object? bytes) + (and len (= total len)) (let ((total (+ total bytes))) (put-bytevector out buffer 0 bytes) (progress total (lambda () (loop total - (get-bytevector-n! in buffer 0 buffer-size))))))) + (get-bytevector-n! in buffer 0 + (if len + (min (- len total) buffer-size) + buffer-size)))))))) ;; Make sure PROGRESS is called when we start so that it can measure ;; throughput. (progress 0 (lambda () - (loop 0 (get-bytevector-n! in buffer 0 buffer-size))))) + (loop 0 (get-bytevector-n! in buffer 0 + (if len + (min len buffer-size) + buffer-size)))))) + +(define AT_SYMLINK_NOFOLLOW + ;; Guile 2.0 did not define this constant, hence this hack. + (let ((variable (module-variable the-root-module 'AT_SYMLINK_NOFOLLOW))) + (if variable + (variable-ref variable) + 256))) ;for GNU/Linux (define (set-file-time file stat) "Set the atime/mtime of FILE to that specified by STAT." @@ -883,7 +1001,8 @@ transferred and the continuation of the transfer as a thunk." (stat:atime stat) (stat:mtime stat) (stat:atimensec stat) - (stat:mtimensec stat))) + (stat:mtimensec stat) + AT_SYMLINK_NOFOLLOW)) (define (get-char* p) ;; We call it `get-char', but that's really a binary version @@ -1307,7 +1426,7 @@ not supported." (lambda () (call-with-ascii-input-file prog (lambda (p) - (format out header) + (display header out) (dump-port p out) (close out) (chmod template mode) |