X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/9d5aa009062a49bd035ae33e37f6562526e7d38c..1306283843c6a933e0dc3bc1eedbc38b687c0d73:/guix/utils.scm diff --git a/guix/utils.scm b/guix/utils.scm index 728039fbf0..b816c355dc 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,12 +1,13 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 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 Mathieu Othacehe -;;; Copyright © 2018 Marius Bakke +;;; Copyright © 2018, 2020 Marius Bakke +;;; Copyright © 2020 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,24 +30,36 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-39) - #:use-module (ice-9 binary-ports) #:use-module (ice-9 ftw) - #:autoload (rnrs io ports) (make-custom-binary-input-port) + #: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 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 @@ -54,23 +67,6 @@ current-source-directory - - 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 - nix-system->gnu-triplet gnu-triplet->nix-system %current-system @@ -81,16 +77,18 @@ 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 @@ -100,6 +98,9 @@ call-with-temporary-directory with-atomic-file-output + with-environment-variables + arguments-from-environment-variable + config-directory cache-directory @@ -115,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. ;;; @@ -175,13 +208,8 @@ buffered data is lost." (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* ((lzlib (false-if-exception (resolve-interface '(guix lzlib)))) - (supported? (and lzlib - ((module-ref lzlib 'lzlib-available?))))) - (if supported? - (let ((make-port (module-ref lzlib proc))) - (values (make-port port) '())) - (error "lzip compression not supported" lzlib)))) + (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, @@ -493,18 +521,26 @@ a character other than '@'." (and target (string-suffix? "-mingw32" target))) -(define (target-arm32?) - (string-prefix? "arm" (or (%current-target-system) (%current-system)))) +(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-aarch64?) - (string-prefix? "aarch64" (or (%current-target-system) (%current-system)))) +(define* (target-arm? #:optional (target (or (%current-target-system) + (%current-system)))) + (or (target-arm32? target) (target-aarch64? target))) -(define (target-arm?) - (or (target-arm32?) (target-aarch64?))) +(define* (target-64bit? #:optional (system (or (%current-target-system) + (%current-system)))) + (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64"))) -(define (target-64bit?) - (let ((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 @@ -525,6 +561,15 @@ 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 @@ -575,6 +620,11 @@ minor version numbers from version-string." (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 #\.))) @@ -627,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 @@ -797,52 +838,6 @@ be determined." ;; 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 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." - ;; 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... - (match loc - ((('line . line) ('column . col) ('filename . file)) ;common case - (and file line col - (make-location file (+ line 1) col))) - (#f - #f) - (_ - (let ((file (assq-ref loc 'filename)) - (line (assq-ref loc 'line)) - (col (assq-ref loc 'column))) - (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)))) - -(define-condition-type &error-location &error - error-location? - (location error-location)) ; - -(define-condition-type &fix-hint &condition - fix-hint? - (hint condition-fix-hint)) ;string - ;;; Local Variables: ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) ;;; End: