;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix build utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-60)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
alist-delete)
#:export (%store-directory
store-file-name?
+ strip-store-file-name
+ package-name->name+version
parallel-job-count
directory-exists?
ar-file?
with-directory-excursion
mkdir-p
+ install-file
copy-recursively
delete-file-recursively
file-name-predicate
list->search-path-as-string
which
+ every*
alist-cons-before
alist-cons-after
alist-replace
modify-phases
+
with-atomic-file-replacement
substitute
substitute*
"Return true if FILE is in the store."
(string-prefix? (%store-directory) file))
+(define (strip-store-file-name file)
+ "Strip the '/gnu/store' and hash from FILE, a store file name. The result
+is typically a \"PACKAGE-VERSION\" string."
+ (string-drop file
+ (+ 34 (string-length (%store-directory)))))
+
+(define (package-name->name+version name)
+ "Given NAME, a package name like \"foo-0.9.1b\", return two values:
+\"foo\" and \"0.9.1b\". When the version part is unavailable, NAME and
+#f are returned. The first hyphen followed by a digit is considered to
+introduce the version part."
+ ;; See also `DrvName' in Nix.
+
+ (define number?
+ (cut char-set-contains? char-set:digit <>))
+
+ (let loop ((chars (string->list name))
+ (prefix '()))
+ (match chars
+ (()
+ (values name #f))
+ ((#\- (? number? n) rest ...)
+ (values (list->string (reverse prefix))
+ (list->string (cons n rest))))
+ ((head tail ...)
+ (loop tail (cons head prefix))))))
+
(define parallel-job-count
;; Number of processes to be passed next to GNU Make's `-j' argument.
(make-parameter
(apply throw args))))))
(() #t))))
+(define (install-file file directory)
+ "Create DIRECTORY if it does not exist and copy FILE in there under the same
+name."
+ (mkdir-p directory)
+ (copy-file file (string-append directory "/" (basename file))))
+
(define* (copy-recursively source destination
#:key
(log (current-output-port))
(regexp-exec file-rx (basename file)))))
(define* (find-files dir #:optional (pred (const #t))
- #:key (stat lstat))
+ #:key (stat lstat)
+ directories?
+ fail-on-error?)
"Return the lexicographically sorted list of files under DIR for which PRED
returns true. PRED is passed two arguments: the absolute file name, and its
stat buffer; the default predicate always returns true. PRED can also be a
regular expression, in which case it is equivalent to (file-name-predicate
PRED). STAT is used to obtain file information; using 'lstat' means that
-symlinks are not followed."
+symlinks are not followed. If DIRECTORIES? is true, then directories will
+also be included. If FAIL-ON-ERROR? is true, raise an exception upon error."
(let ((pred (if (procedure? pred)
pred
(file-name-predicate pred))))
(cons file result)
result))
(lambda (dir stat result) ; down
- result)
+ (if (and directories?
+ (pred dir stat))
+ (cons dir result)
+ result))
(lambda (dir stat result) ; up
result)
(lambda (file stat result) ; skip
(lambda (file stat errno result)
(format (current-error-port) "find-files: ~a: ~a~%"
file (strerror errno))
+ (when fail-on-error?
+ (error "find-files failed"))
result)
'()
dir
(append-map (lambda (input)
(append-map (lambda (file)
(let ((file (string-append input "/" file)))
- ;; XXX: By using 'find-files', we implicitly
- ;; assume #:type 'regular.
(if pattern
- (find-files file pattern)
+ (find-files file (lambda (file stat)
+ (and stat
+ (eq? type (stat:type stat))
+ ((file-name-predicate pattern) file stat)))
+ #:stat stat
+ #:directories? #t)
(let ((stat (stat file #f)))
(if (and stat (eq? type (stat:type stat)))
(list file)
;;; phases.
;;;
+(define (every* pred lst)
+ "This is like 'every', but process all the elements of LST instead of
+stopping as soon as PRED returns false. This is useful when PRED has side
+effects, such as displaying warnings or error messages."
+ (let loop ((lst lst)
+ (result #t))
+ (match lst
+ (()
+ result)
+ ((head . tail)
+ (loop tail (and (pred head) result))))))
+
(define* (alist-cons-before reference key value alist
#:optional (key=? equal?))
"Insert the KEY/VALUE pair before the first occurrence of a pair whose key
(add-before <old-phase-name> <new-phase-name> <new-phase>)
(add-after <old-phase-name> <new-phase-name> <new-phase>)
-Where every <*-phase-name> is an automatically quoted symbol, and <new-phase>
-an expression evaluating to a procedure."
+Where every <*-phase-name> is an expression evaluating to a symbol, and
+<new-phase> an expression evaluating to a procedure."
(let* ((phases* phases)
(phases* (%modify-phases phases* mod-spec))
...)
programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or
modules in $GUILE_LOAD_PATH, etc.
-If PROG has previously been wrapped by wrap-program the wrapper will point to
-the previous wrapper."
- (define (wrapper-file-name number)
- (format #f "~a/.~a-wrap-~2'0d" (dirname prog) (basename prog) number))
- (define (next-wrapper-number)
- (let ((wrappers
- (find-files (dirname prog)
- (string-append "\\." (basename prog) "-wrap-.*"))))
- (if (null? wrappers)
- 0
- (string->number (string-take-right (last wrappers) 2)))))
- (define (wrapper-target number)
- (if (zero? number)
- (let ((prog-real (string-append (dirname prog) "/."
- (basename prog) "-real")))
- (rename-file prog prog-real)
- prog-real)
- (wrapper-file-name number)))
-
- (let* ((number (next-wrapper-number))
- (target (wrapper-target number))
- (wrapper (wrapper-file-name (1+ number)))
- (prog-tmp (string-append target "-tmp")))
- (define (export-variable lst)
- ;; Return a string that exports an environment variable.
- (match lst
- ((var sep '= rest)
- (format #f "export ~a=\"~a\""
- var (string-join rest sep)))
- ((var sep 'prefix rest)
- (format #f "export ~a=\"~a${~a~a+~a}$~a\""
- var (string-join rest sep) var sep sep var))
- ((var sep 'suffix rest)
- (format #f "export ~a=\"$~a${~a~a+~a}~a\""
- var var var sep sep (string-join rest sep)))
- ((var '= rest)
- (format #f "export ~a=\"~a\""
- var (string-join rest ":")))
- ((var 'prefix rest)
- (format #f "export ~a=\"~a${~a:+:}$~a\""
- var (string-join rest ":") var var))
- ((var 'suffix rest)
- (format #f "export ~a=\"$~a${~a:+:}~a\""
- var var var (string-join rest ":")))))
-
- (with-output-to-file prog-tmp
- (lambda ()
- (format #t
- "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
- (which "bash")
- (string-join (map export-variable vars)
- "\n")
- (canonicalize-path target))))
-
- (chmod prog-tmp #o755)
- (rename-file prog-tmp wrapper)
- (symlink wrapper prog-tmp)
- (rename-file prog-tmp prog)))
+If PROG has previously been wrapped by 'wrap-program', the wrapper is extended
+with definitions for VARS."
+ (define wrapped-file
+ (string-append (dirname prog) "/." (basename prog) "-real"))
+
+ (define already-wrapped?
+ (file-exists? wrapped-file))
+
+ (define (last-line port)
+ ;; Return the last line read from PORT and leave PORT's cursor right
+ ;; before it.
+ (let loop ((previous-line-offset 0)
+ (previous-line "")
+ (position (seek port 0 SEEK_CUR)))
+ (match (read-line port 'concat)
+ ((? eof-object?)
+ (seek port previous-line-offset SEEK_SET)
+ previous-line)
+ ((? string? line)
+ (loop position line (+ (string-length line) position))))))
+
+ (define (export-variable lst)
+ ;; Return a string that exports an environment variable.
+ (match lst
+ ((var sep '= rest)
+ (format #f "export ~a=\"~a\""
+ var (string-join rest sep)))
+ ((var sep 'prefix rest)
+ (format #f "export ~a=\"~a${~a~a+~a}$~a\""
+ var (string-join rest sep) var sep sep var))
+ ((var sep 'suffix rest)
+ (format #f "export ~a=\"$~a${~a~a+~a}~a\""
+ var var var sep sep (string-join rest sep)))
+ ((var '= rest)
+ (format #f "export ~a=\"~a\""
+ var (string-join rest ":")))
+ ((var 'prefix rest)
+ (format #f "export ~a=\"~a${~a:+:}$~a\""
+ var (string-join rest ":") var var))
+ ((var 'suffix rest)
+ (format #f "export ~a=\"$~a${~a:+:}~a\""
+ var var var (string-join rest ":")))))
+
+ (if already-wrapped?
+
+ ;; PROG is already a wrapper: add the new "export VAR=VALUE" lines just
+ ;; before the last line.
+ (let* ((port (open-file prog "r+"))
+ (last (last-line port)))
+ (for-each (lambda (var)
+ (display (export-variable var) port)
+ (newline port))
+ vars)
+ (display last port)
+ (close-port port))
+
+ ;; PROG is not wrapped yet: create a shell script that sets VARS.
+ (let ((prog-tmp (string-append wrapped-file "-tmp")))
+ (link prog wrapped-file)
+
+ (call-with-output-file prog-tmp
+ (lambda (port)
+ (format port
+ "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
+ (which "bash")
+ (string-join (map export-variable vars) "\n")
+ (canonicalize-path wrapped-file))))
+
+ (chmod prog-tmp #o755)
+ (rename-file prog-tmp prog))))
\f
;;;
HCoop / jackhill / guix / guix.git / blobdiff