;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org>
+;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
#: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) ;<location>, &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 (<location> ;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
current-source-directory
- <location>
- 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
canonical-newline-port))
\f
+;;;
+;;; 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)
+ '())))
+
+\f
;;;
;;; Filtering & pipes.
;;;
(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
(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 '()))
(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))
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>.<minor>.<point>\", 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 \"<major>.<minor>\", 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)))
(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)))))
+
+\f
+;;;
+;;; Files.
+;;;
+
(define (file-extension file)
"Return the extension of FILE or #f if there is none."
(let ((dot (string-rindex file #\.)))
(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)
(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
(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.
(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)
(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))))))
;;; 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)
;; 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 <location>
- (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 <location> 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:
HCoop / jackhill / guix / guix.git / blobdiff