diff options
Diffstat (limited to 'guix/utils.scm')
| -rw-r--r-- | guix/utils.scm | 245 |
1 files changed, 194 insertions, 51 deletions
diff --git a/guix/utils.scm b/guix/utils.scm index 2920fa7684..9596ff8582 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -7,9 +7,11 @@ ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org> -;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020, 2021 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; @@ -35,11 +37,14 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-39) + #:use-module (srfi srfi-71) #:use-module (ice-9 ftw) #:use-module (rnrs io ports) ;need 'port-position' etc. #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module (guix memoization) - #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively)) + #:use-module ((guix build utils) + #:select (dump-port mkdir-p delete-file-recursively + call-with-temporary-output-file %xz-parallel-args)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) #:use-module ((guix combinators) #:select (fold2)) #:use-module (guix diagnostics) ;<location>, &error-location, etc. @@ -48,6 +53,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module ((ice-9 iconv) #:prefix iconv:) + #:use-module (ice-9 vlist) #:autoload (zlib) (make-zlib-input-port make-zlib-output-port) #:use-module (system foreign) #:re-export (<location> ;for backwards compatibility @@ -65,7 +71,9 @@ &fix-hint fix-hint? - condition-fix-hint) + condition-fix-hint + + call-with-temporary-output-file) #:export (strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments @@ -78,11 +86,18 @@ %current-system %current-target-system package-name->name+version + target-linux? + target-hurd? target-mingw? + target-x86-32? + target-x86-64? target-arm32? target-aarch64? target-arm? + target-ppc32? + target-ppc64le? target-powerpc? + target-riscv64? target-64bit? cc-for-target cxx-for-target @@ -104,7 +119,6 @@ tarball-sans-extension compressed-file? switch-symlinks - call-with-temporary-output-file call-with-temporary-directory with-atomic-file-output @@ -115,6 +129,7 @@ cache-directory readlink* + go-to-location edit-expression filtered-port @@ -246,6 +261,18 @@ a symbol such as 'xz." '())) (_ (error "unsupported compression scheme" compression)))) +(define (compressed-port compression input) + "Return an input port where INPUT is compressed according to COMPRESSION, +a symbol such as 'xz." + (match compression + ((or #f 'none) (values input '())) + ('bzip2 (filtered-port `(,%bzip2 "-c") input)) + ('xz (filtered-port `(,%xz "-c" ,@(%xz-parallel-args)) input)) + ('gzip (filtered-port `(,%gzip "-c") input)) + ('lzip (values (lzip-port 'make-lzip-input-port/compressed input) + '())) + (_ (error "unsupported compression scheme" compression)))) + (define (call-with-decompressed-port compression port proc) "Call PROC with a wrapper around PORT, a file port, that decompresses data read from PORT according to COMPRESSION, a symbol such as 'xz." @@ -325,43 +352,129 @@ a list of command-line arguments passed to the compression program." (unless (every (compose zero? cdr waitpid) pids) (error "compressed-output-port failure" pids)))))) +(define %source-location-map + ;; Maps inode/device tuples to "source location maps" used by + ;; 'go-to-location'. + (make-hash-table)) + +(define (source-location-key/stamp stat) + "Return two values: the key for STAT in %SOURCE-LOCATION-MAP, and a stamp +used to invalidate corresponding entries." + (let ((key (list (stat:ino stat) (stat:dev stat))) + (stamp (list (stat:mtime stat) (stat:mtimensec stat) + (stat:size stat)))) + (values key stamp))) + +(define* (go-to-location port line column) + "Jump to LINE and COLUMN (both one-indexed) in PORT. Maintain a source +location map such that this can boil down to seek(2) and a few read(2) calls, +which can drastically speed up repetitive operations on large files." + (let* ((stat (stat port)) + (key stamp (source-location-key/stamp stat)) + + ;; Look for an up-to-date source map for KEY. The map is a vlist + ;; where each entry gives the byte offset of the beginning of a line: + ;; element 0 is the offset of the first line, element 1 the offset of + ;; the second line, etc. The map is filled lazily. + (source-map (match (hash-ref %source-location-map key) + (#f + (vlist-cons 0 vlist-null)) + ((cache-stamp ... map) + (if (equal? cache-stamp stamp) ;invalidate? + map + (vlist-cons 0 vlist-null))))) + (last (vlist-length source-map))) + ;; Jump to LINE, ideally via SOURCE-MAP. + (if (<= line last) + (seek port (vlist-ref source-map (- line 1)) SEEK_SET) + (let ((target line) + (offset (vlist-ref source-map (- last 1)))) + (seek port offset SEEK_SET) + (let loop ((source-map (vlist-reverse source-map)) + (line last)) + (if (< line target) + (match (read-char port) + (#\newline + (loop (vlist-cons (ftell port) source-map) + (+ 1 line))) + ((? eof-object?) + (error "unexpected end of file" port line)) + (chr (loop source-map line))) + (hash-set! %source-location-map key + `(,@stamp + ,(vlist-reverse source-map))))))) + + ;; Read up to COLUMN. + (let ((target column)) + (let loop ((column 1)) + (when (< column target) + (match (read-char port) + (#\newline (error "unexpected end of line" port)) + (#\tab (loop (+ 8 column))) + (chr (loop (+ 1 column))))))) + + ;; Update PORT's position info. + (set-port-line! port (- line 1)) + (set-port-column! port (- column 1)))) + +(define (move-source-location-map! source target line) + "Move the source location map from SOURCE up to LINE to TARGET. SOURCE and +TARGET must be stat buffers as returned by 'stat'." + (let* ((source-key (source-location-key/stamp source)) + (target-key target-stamp (source-location-key/stamp target))) + (match (hash-ref %source-location-map source-key) + (#f #t) + ((_ ... source-map) + ;; Strip the source map and update the associated stamp. + (let ((source-map (vlist-take source-map (max line 1)))) + (hash-remove! %source-location-map source-key) + (hash-set! %source-location-map target-key + `(,@target-stamp ,source-map))))))) + (define* (edit-expression source-properties proc #:key (encoding "UTF-8")) "Edit the expression specified by SOURCE-PROPERTIES using PROC, which should be a procedure that takes the original expression in string and returns a new one. ENCODING will be used to interpret all port I/O, it default to UTF-8. This procedure returns #t on success." + (define file (assq-ref source-properties 'filename)) + (define line (assq-ref source-properties 'line)) + (define column (assq-ref source-properties 'column)) + (with-fluids ((%default-port-encoding encoding)) - (let* ((file (assq-ref source-properties 'filename)) - (line (assq-ref source-properties 'line)) - (column (assq-ref source-properties 'column)) - (in (open-input-file file)) - ;; The start byte position of the expression. - (start (begin (while (not (and (= line (port-line in)) - (= column (port-column in)))) - (when (eof-object? (read-char in)) - (error (format #f "~a: end of file~%" in)))) - (ftell in))) - ;; The end byte position of the expression. - (end (begin (read in) (ftell in)))) - (seek in 0 SEEK_SET) ; read from the beginning of the file. - (let* ((pre-bv (get-bytevector-n in start)) - ;; The expression in string form. - (str (iconv:bytevector->string - (get-bytevector-n in (- end start)) - (port-encoding in))) - (post-bv (get-bytevector-all in)) - (str* (proc str))) - ;; Verify the edited expression is still a scheme expression. - (call-with-input-string str* read) - ;; Update the file with edited expression. - (with-atomic-file-output file - (lambda (out) - (put-bytevector out pre-bv) - (display str* out) - ;; post-bv maybe the end-of-file object. - (when (not (eof-object? post-bv)) - (put-bytevector out post-bv)) - #t)))))) + (call-with-input-file file + (lambda (in) + (let* ( ;; The start byte position of the expression. + (start (begin (go-to-location in (+ 1 line) (+ 1 column)) + (ftell in))) + ;; The end byte position of the expression. + (end (begin (read in) (ftell in)))) + (seek in 0 SEEK_SET) ; read from the beginning of the file. + (let* ((pre-bv (get-bytevector-n in start)) + ;; The expression in string form. + (str (iconv:bytevector->string + (get-bytevector-n in (- end start)) + (port-encoding in))) + (post-bv (get-bytevector-all in)) + (str* (proc str))) + ;; Modify FILE only if there are changes. + (unless (string=? str* str) + ;; Verify the edited expression is still a scheme expression. + (call-with-input-string str* read) + ;; Update the file with edited expression. + (with-atomic-file-output file + (lambda (out) + (put-bytevector out pre-bv) + (display str* out) + ;; post-bv maybe the end-of-file object. + (when (not (eof-object? post-bv)) + (put-bytevector out post-bv)) + #t)) + + ;; Due to 'with-atomic-file-output', IN and FILE no longer share + ;; the same inode, but we can reassign the source map up to LINE + ;; to the new file. + (move-source-location-map! (stat in) (stat file) + (+ 1 line))))))))) ;;; @@ -531,10 +644,43 @@ a character other than '@'." (idx (values (substring spec 0 idx) (substring spec (1+ idx)))))) +(define* (target-linux? #:optional (target (or (%current-target-system) + (%current-system)))) + "Does the operating system of TARGET use the Linux kernel?" + (->bool (string-contains target "linux"))) + +(define* (target-hurd? #:optional (target (or (%current-target-system) + (%current-system)))) + "Does TARGET represent the GNU(/Hurd) system?" + (and (string-suffix? "-gnu" target) + (not (string-contains target "linux")))) + (define* (target-mingw? #:optional (target (%current-target-system))) + "Is the operating system of TARGET Windows?" (and target + ;; The "-32" doesn't mean TARGET is 32-bit, as "x86_64-w64-mingw32" + ;; is a valid triplet (see the (gnu ci) module) and 'w64' and 'x86_64' + ;; are 64-bit. (string-suffix? "-mingw32" target))) +(define* (target-x86-32? #:optional (target (or (%current-target-system) + (%current-system)))) + "Is the architecture of TARGET a variant of Intel's 32-bit architecture +(IA32)?" + ;; Intel also has a 16-bit architecture in the iN86 series, i286 + ;; (see, e.g. https://en.wikipedia.org/wiki/Intel/808286) so this + ;; procedure is not named target-x86?. + (or (string-prefix? "i386-" target) + (string-prefix? "i486-" target) + (string-prefix? "i586-" target) + (string-prefix? "i686-" target))) + +(define* (target-x86-64? #:optional (target (or (%current-target-system) + (%current-system)))) + "Is the architecture of TARGET a variant of Intel/AMD's 64-bit +architecture (x86_64)?" + (string-prefix? "x86_64-" target)) + (define* (target-arm32? #:optional (target (or (%current-target-system) (%current-system)))) (string-prefix? "arm" target)) @@ -547,10 +693,23 @@ a character other than '@'." (%current-system)))) (or (target-arm32? target) (target-aarch64? target))) +(define* (target-ppc32? #:optional (target (or (%current-target-system) + (%current-system)))) + (string-prefix? "powerpc-" target)) + +(define* (target-ppc64le? #:optional (target (or (%current-target-system) + (%current-system)))) + (string-prefix? "powerpc64le-" target)) + (define* (target-powerpc? #:optional (target (or (%current-target-system) (%current-system)))) (string-prefix? "powerpc" target)) +(define* (target-riscv64? #:optional (target (or (%current-target-system) + (%current-system)))) + "Is the architecture of TARGET a 'riscv64' machine?" + (string-prefix? "riscv64" target)) + (define* (target-64bit? #:optional (system (or (%current-target-system) (%current-system)))) (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "powerpc64"))) @@ -738,22 +897,6 @@ REPLACEMENT." (substring str start index) pieces)))))))) -(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-temporary-directory proc) "Call PROC with a name of a temporary directory; close the directory and delete it when leaving the dynamic extent of this call." |