summaryrefslogtreecommitdiff
path: root/guix/build/utils.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/build/utils.scm')
-rw-r--r--guix/build/utils.scm187
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)