X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/eda8a841ac7457ffe05c4a4248d6dff074b72326..1306283843c6a933e0dc3bc1eedbc38b687c0d73:/guix/utils.scm diff --git a/guix/utils.scm b/guix/utils.scm index eb1ec29b32..b816c355dc 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,11 +1,13 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2013, 2014, 2015 Mark H Weaver ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2014 Ian Denhardt ;;; Copyright © 2016 Mathieu Lirzin ;;; Copyright © 2015 David Thompson -;;; Copyright © 2017 Efraim Flashner +;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018, 2020 Marius Bakke +;;; Copyright © 2020 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,21 +31,35 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-39) - #:use-module (ice-9 binary-ports) - #:autoload (rnrs io ports) (make-custom-binary-input-port) + #: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)) + #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) + #:use-module (guix diagnostics) ;, &error-location, etc. #:use-module (ice-9 format) - #:autoload (ice-9 popen) (open-pipe*) - #:autoload (ice-9 rdelim) (read-line) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module ((ice-9 iconv) #:prefix iconv:) #:use-module (system foreign) - #:re-export (memoize) ; for backwards compatibility + #:re-export ( ;for backwards compatibility + location + location? + location-file + location-line + location-column + source-properties->location + location->source-properties + + &error-location + error-location? + error-location + + &fix-hint + fix-hint? + condition-fix-hint) #:export (strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments @@ -51,37 +67,40 @@ current-source-directory - - location - location? - location-file - location-line - location-column - source-properties->location - location->source-properties - nix-system->gnu-triplet gnu-triplet->nix-system %current-system %current-target-system package-name->name+version target-mingw? + target-arm32? + target-aarch64? + target-arm? + target-64bit? + cc-for-target + version-compare version>? version>=? version-prefix + version-major+minor+point version-major+minor + version-major guile-version>? + version-prefix? string-replace-substring - arguments-from-environment-variable file-extension file-sans-extension + tarball-sans-extension compressed-file? switch-symlinks call-with-temporary-output-file call-with-temporary-directory with-atomic-file-output + with-environment-variables + arguments-from-environment-variable + config-directory cache-directory @@ -97,6 +116,38 @@ canonical-newline-port)) +;;; +;;; Environment variables. +;;; + +(define (call-with-environment-variables variables thunk) + "Call THUNK with the environment VARIABLES set." + (let ((environment (environ))) + (dynamic-wind + (lambda () + (for-each (match-lambda + ((variable value) + (setenv variable value))) + variables)) + thunk + (lambda () + (environ environment))))) + +(define-syntax-rule (with-environment-variables variables exp ...) + "Evaluate EXP with the given environment VARIABLES set." + (call-with-environment-variables variables + (lambda () exp ...))) + +(define (arguments-from-environment-variable variable) + "Retrieve value of environment variable denoted by string VARIABLE in the +form of a list of strings (`char-set:graphic' tokens) suitable for consumption +by `args-fold', if VARIABLE is defined, otherwise return an empty list." + (let ((env (getenv variable))) + (if env + (string-tokenize env char-set:graphic) + '()))) + + ;;; ;;; Filtering & pipes. ;;; @@ -154,25 +205,35 @@ buffered data is lost." (close-port out) (loop in (cons child pids))))))))) +(define (lzip-port proc port . args) + "Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS. +Raise an error if lzlib support is missing." + (let ((make-port (module-ref (resolve-interface '(lzlib)) proc))) + (values (make-port port) '()))) + (define (decompressed-port compression input) "Return an input port where INPUT is decompressed according to COMPRESSION, a symbol such as 'xz." (match compression ((or #f 'none) (values input '())) ('bzip2 (filtered-port `(,%bzip2 "-dc") input)) - ('xz (filtered-port `(,%xz "-dc" "-T0") input)) + ('xz (filtered-port `(,%xz "-dc") input)) ('gzip (filtered-port `(,%gzip "-dc") input)) - (else (error "unsupported compression scheme" compression)))) + ('lzip (values (lzip-port 'make-lzip-input-port input) + '())) + (_ (error "unsupported compression scheme" compression)))) (define (compressed-port compression input) - "Return an input port where INPUT is decompressed according to COMPRESSION, + "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" "-T0") input)) + ('xz (filtered-port `(,%xz "-c") input)) ('gzip (filtered-port `(,%gzip "-c") input)) - (else (error "unsupported compression scheme" compression)))) + ('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 @@ -227,9 +288,11 @@ program--e.g., '(\"--fast\")." (match compression ((or #f 'none) (values output '())) ('bzip2 (filtered-output-port `(,%bzip2 "-c" ,@options) output)) - ('xz (filtered-output-port `(,%xz "-c" "-T0" ,@options) output)) + ('xz (filtered-output-port `(,%xz "-c" ,@options) output)) ('gzip (filtered-output-port `(,%gzip "-c" ,@options) output)) - (else (error "unsupported compression scheme" compression)))) + ('lzip (values (lzip-port 'make-lzip-output-port output) + '())) + (_ (error "unsupported compression scheme" compression)))) (define* (call-with-compressed-output-port compression port proc #:key (options '())) @@ -458,6 +521,27 @@ a character other than '@'." (and target (string-suffix? "-mingw32" target))) +(define* (target-arm32? #:optional (target (or (%current-target-system) + (%current-system)))) + (string-prefix? "arm" target)) + +(define* (target-aarch64? #:optional (target (or (%current-target-system) + (%current-system)))) + (string-prefix? "aarch64" target)) + +(define* (target-arm? #:optional (target (or (%current-target-system) + (%current-system)))) + (or (target-arm32? target) (target-aarch64? target))) + +(define* (target-64bit? #:optional (system (or (%current-target-system) + (%current-system)))) + (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64"))) + +(define* (cc-for-target #:optional (target (%current-target-system))) + (if target + (string-append target "-gcc") + "gcc")) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) @@ -477,12 +561,25 @@ or '= when they denote equal versions." For example, (version-prefix \"2.1.47.4.23\" 3) returns \"2.1.47\"" (string-join (take (string-split version-string #\.) num-parts) ".")) +(define (version-major+minor+point version-string) + "Return \"major>..\", where major, minor and point are the +major, minor and point version numbers from the version-string. For example, +(version-major+minor+point \"6.4.5.2\") returns \"6.4.5\" or +(version-major+minor+point \"1.19.2-2581-324ca14c3003\") returns \"1.19.2\"." + (let* ((3-dot (version-prefix version-string 3)) + (index (string-index 3-dot #\-))) + (or (false-if-exception (substring 3-dot 0 index)) + 3-dot))) (define (version-major+minor version-string) "Return \".\", where major and minor are the major and minor version numbers from version-string." (version-prefix version-string 2)) +(define (version-major version-string) + "Return the major version number as string from the version-string." + (version-prefix version-string 1)) + (define (version>? a b) "Return #t when A denotes a version strictly newer than B." (eq? '> (version-compare a b))) @@ -502,6 +599,32 @@ minor version numbers from version-string." (micro-version)) str)) +(define version-prefix? + (let ((not-dot (char-set-complement (char-set #\.)))) + (lambda (v1 v2) + "Return true if V1 is a version prefix of V2: + + (version-prefix? \"4.1\" \"4.16.2\") => #f + (version-prefix? \"4.1\" \"4.1.2\") => #t +" + (define (list-prefix? lst1 lst2) + (match lst1 + (() #t) + ((head1 tail1 ...) + (match lst2 + (() #f) + ((head2 tail2 ...) + (and (equal? head1 head2) + (list-prefix? tail1 tail2))))))) + + (list-prefix? (string-tokenize v1 not-dot) + (string-tokenize v2 not-dot))))) + + +;;; +;;; Files. +;;; + (define (file-extension file) "Return the extension of FILE or #f if there is none." (let ((dot (string-rindex file #\.))) @@ -514,6 +637,12 @@ minor version numbers from version-string." (substring file 0 dot) file))) +(define (tarball-sans-extension tarball) + "Return TARBALL without its .tar.* or .zip extension." + (let ((end (or (string-contains tarball ".tar") + (string-contains tarball ".zip")))) + (substring tarball 0 end))) + (define (compressed-file? file) "Return true if FILE denotes a compressed file." (->bool (member (file-extension file) @@ -548,15 +677,6 @@ REPLACEMENT." (substring str start index) pieces)))))))) -(define (arguments-from-environment-variable variable) - "Retrieve value of environment variable denoted by string VARIABLE in the -form of a list of strings (`char-set:graphic' tokens) suitable for consumption -by `args-fold', if VARIABLE is defined, otherwise return an empty list." - (let ((env (getenv variable))) - (if env - (string-tokenize env char-set:graphic) - '()))) - (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 @@ -584,7 +704,7 @@ delete it when leaving the dynamic extent of this call." (lambda () (proc tmp-dir)) (lambda () - (false-if-exception (rmdir tmp-dir)))))) + (false-if-exception (delete-file-recursively tmp-dir)))))) (define (with-atomic-file-output file proc) "Call PROC with an output port for the file that is going to replace FILE. @@ -654,7 +774,7 @@ environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like (define (canonical-newline-port port) "Return an input port that wraps PORT such that all newlines consist - of a single carriage return." + of a single linefeed." (define (get-position) (if (port-has-port-position? port) (port-position port) #f)) (define (set-position! position) @@ -666,11 +786,11 @@ environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like (let loop ((count 0) (byte (get-u8 port))) (cond ((eof-object? byte) count) + ;; XXX: consume all CRs even if not followed by LF. + ((eqv? byte (char->integer #\return)) (loop count (get-u8 port))) ((= count (- n 1)) (bytevector-u8-set! bv (+ start count) byte) n) - ;; XXX: consume all LFs even if not followed by CR. - ((eqv? byte (char->integer #\return)) (loop count (get-u8 port))) (else (bytevector-u8-set! bv (+ start count) byte) (loop (+ count 1) (get-u8 port)))))) @@ -684,17 +804,19 @@ environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like ;;; Source location. ;;; -(define (absolute-dirname file) - "Return the absolute name of the directory containing FILE, or #f upon +(define absolute-dirname + ;; Memoize to avoid repeated 'stat' storms from 'search-path'. + (mlambda (file) + "Return the absolute name of the directory containing FILE, or #f upon failure." - (match (search-path %load-path file) - (#f #f) - ((? string? file) - ;; If there are relative names in %LOAD-PATH, FILE can be relative and - ;; needs to be canonicalized. - (if (string-prefix? "/" file) - (dirname file) - (canonicalize-path (dirname file)))))) + (match (search-path %load-path file) + (#f #f) + ((? string? file) + ;; If there are relative names in %LOAD-PATH, FILE can be relative and + ;; needs to be canonicalized. + (if (string-prefix? "/" file) + (dirname file) + (canonicalize-path (dirname file))))))) (define-syntax current-source-directory (lambda (s) @@ -709,47 +831,13 @@ be determined." ;; the absolute file name by looking at %LOAD-PATH; doing this at ;; run time rather than expansion time is necessary to allow files ;; to be moved on the file system. - (cond ((not file-name) - #f) ;raising an error would upset Geiser users - ((string-prefix? "/" file-name) - (dirname file-name)) - (else - #`(absolute-dirname #,file-name)))) - (#f + (if (string-prefix? "/" file-name) + (dirname file-name) + #`(absolute-dirname #,file-name))) + ((or ('filename . #f) #f) + ;; raising an error would upset Geiser users #f)))))) -;; A source location. -(define-record-type - (make-location file line column) - location? - (file location-file) ; file name - (line location-line) ; 1-indexed line - (column location-column)) ; 0-indexed column - -(define location - (mlambda (file line column) - "Return the object for the given FILE, LINE, and COLUMN." - (and line column file - (make-location file line column)))) - -(define (source-properties->location loc) - "Return a location object based on the info in LOC, an alist as returned -by Guile's `source-properties', `frame-source', `current-source-location', -etc." - (let ((file (assq-ref loc 'filename)) - (line (assq-ref loc 'line)) - (col (assq-ref loc 'column))) - ;; In accordance with the GCS, start line and column numbers at 1. Note - ;; that unlike LINE and `port-column', COL is actually 1-indexed here... - (location file (and line (+ line 1)) col))) - -(define (location->source-properties loc) - "Return the source property association list based on the info in LOC, -a location object." - `((line . ,(and=> (location-line loc) 1-)) - (column . ,(location-column loc)) - (filename . ,(location-file loc)))) - ;;; Local Variables: ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) ;;; End: