;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 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)
#:use-module (ice-9 regex)
#:re-export (alist-cons
alist-delete)
#:export (%store-directory
+ store-file-name?
+ strip-store-file-name
+ package-name->name+version
parallel-job-count
directory-exists?
executable-file?
+ symbolic-link?
call-with-ascii-input-file
elf-file?
+ ar-file?
with-directory-excursion
mkdir-p
+ install-file
copy-recursively
delete-file-recursively
+ file-name-predicate
find-files
+ search-path-as-list
set-path-environment-variable
search-path-as-string->list
list->search-path-as-string
which
+ every*
alist-cons-before
alist-cons-after
alist-replace
+ modify-phases
+
with-atomic-file-replacement
substitute
substitute*
set-file-time
patch-shebang
patch-makefile-SHELL
+ patch-/usr/bin/file
fold-port-matches
remove-store-references
- wrap-program))
+ wrap-program
+
+ locale-category->string))
;;;
(or (getenv "NIX_STORE")
"/gnu/store"))
-(define (parallel-job-count)
- "Return the number of processes to be passed next to GNU Make's `-j'
-argument."
- (match (getenv "NIX_BUILD_CORES") ;set by the daemon
- (#f 1)
- ("0" (current-processor-count))
- (x (or (string->number x) 1))))
+(define (store-file-name? file)
+ "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
+ (match (getenv "NIX_BUILD_CORES") ;set by the daemon
+ (#f 1)
+ ("0" (current-processor-count))
+ (x (or (string->number x) 1)))))
(define (directory-exists? dir)
"Return #t if DIR exists and is a directory."
(and s
(not (zero? (logand (stat:mode s) #o100))))))
+(define (symbolic-link? file)
+ "Return #t if FILE is a symbolic link (aka. \"symlink\".)"
+ (eq? (stat:type (lstat file)) 'symlink))
+
(define (call-with-ascii-input-file file proc)
"Open FILE as an ASCII or binary file, and pass the resulting port to
PROC. FILE is closed when PROC's dynamic extent is left. Return the
(lambda ()
(close-input-port port)))))
-(define (elf-file? file)
- "Return true if FILE starts with the ELF magic bytes."
- (define (get-header)
- (call-with-input-file file
- (lambda (port)
- (get-bytevector-n port 4))
- #:binary #t #:guess-encoding #f))
+(define (file-header-match header)
+ "Return a procedure that returns true when its argument is a file starting
+with the bytes in HEADER, a bytevector."
+ (define len
+ (bytevector-length header))
+
+ (lambda (file)
+ "Return true if FILE starts with the right magic bytes."
+ (define (get-header)
+ (call-with-input-file file
+ (lambda (port)
+ (get-bytevector-n port len))
+ #:binary #t #:guess-encoding #f))
+
+ (catch 'system-error
+ (lambda ()
+ (equal? (get-header) header))
+ (lambda args
+ (if (= EISDIR (system-error-errno args))
+ #f ;FILE is a directory
+ (apply throw args))))))
+
+(define %elf-magic-bytes
+ ;; Magic bytes of ELF files. See <elf.h>.
+ (u8-list->bytevector (map char->integer (string->list "\x7FELF"))))
- (equal? (get-header)
- #vu8(#x7f #x45 #x4c #x46))) ;"\177ELF"
+(define elf-file?
+ (file-header-match %elf-magic-bytes))
+
+(define %ar-magic-bytes
+ ;; Magic bytes of archives created by 'ar'. See <ar.h>.
+ (u8-list->bytevector (map char->integer (string->list "!<arch>\n"))))
+
+(define ar-file?
+ (file-header-match %ar-magic-bytes))
(define-syntax-rule (with-directory-excursion dir body ...)
"Run BODY with DIR as the process's current directory."
(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))
;; Don't follow symlinks.
lstat)))
-(define (find-files dir regexp)
- "Return the lexicographically sorted list of files under DIR whose basename
-matches REGEXP."
- (define file-rx
- (if (regexp? regexp)
- regexp
- (make-regexp regexp)))
-
- ;; Sort the result to get deterministic results.
- (sort (file-system-fold (const #t)
- (lambda (file stat result) ; leaf
- (if (regexp-exec file-rx (basename file))
- (cons file result)
- result))
- (lambda (dir stat result) ; down
- result)
- (lambda (dir stat result) ; up
- result)
- (lambda (file stat result) ; skip
- result)
- (lambda (file stat errno result)
- (format (current-error-port) "find-files: ~a: ~a~%"
- file (strerror errno))
- result)
- '()
- dir)
- string<?))
+(define (file-name-predicate regexp)
+ "Return a predicate that returns true when passed a file name whose base
+name matches REGEXP."
+ (let ((file-rx (if (regexp? regexp)
+ regexp
+ (make-regexp regexp))))
+ (lambda (file stat)
+ (regexp-exec file-rx (basename file)))))
+
+(define* (find-files dir #:optional (pred (const #t))
+ #: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. 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))))
+ ;; Sort the result to get deterministic results.
+ (sort (file-system-fold (const #t)
+ (lambda (file stat result) ; leaf
+ (if (pred file stat)
+ (cons file result)
+ result))
+ (lambda (dir stat result) ; down
+ (if (and directories?
+ (pred dir stat))
+ (cons dir result)
+ result))
+ (lambda (dir stat result) ; up
+ result)
+ (lambda (file stat result) ; skip
+ result)
+ (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
+ stat)
+ string<?)))
\f
;;;
;;; Search paths.
;;;
-(define (search-path-as-list sub-directories input-dirs)
- "Return the list of directories among SUB-DIRECTORIES that exist in
-INPUT-DIRS. Example:
+(define* (search-path-as-list files input-dirs
+ #:key (type 'directory) pattern)
+ "Return the list of directories among FILES of the given TYPE (a symbol as
+returned by 'stat:type') that exist in INPUT-DIRS. Example:
(search-path-as-list '(\"share/emacs/site-lisp\" \"share/emacs/24.1\")
(list \"/package1\" \"/package2\" \"/package3\"))
=> (\"/package1/share/emacs/site-lisp\"
\"/package3/share/emacs/site-lisp\")
+When PATTERN is true, it is a regular expression denoting file names to look
+for under the directories designated by FILES. For example:
+
+ (search-path-as-list '(\"xml\") (list docbook-xml docbook-xsl)
+ #:type 'regular
+ #:pattern \"^catalog\\\\.xml$\")
+ => (\"/…/xml/dtd/docbook/catalog.xml\"
+ \"/…/xml/xsl/docbook-xsl-1.78.1/catalog.xml\")
"
(append-map (lambda (input)
- (filter-map (lambda (dir)
- (let ((dir (string-append input "/"
- dir)))
- (and (directory-exists? dir)
- dir)))
- sub-directories))
- input-dirs))
+ (append-map (lambda (file)
+ (let ((file (string-append input "/" file)))
+ (if 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)
+ '())))))
+ files))
+ (delete-duplicates input-dirs)))
(define (list->search-path-as-string lst separator)
(string-join lst separator))
(define* (search-path-as-string->list path #:optional (separator #\:))
(string-tokenize path (char-set-complement (char-set separator))))
-(define* (set-path-environment-variable env-var sub-directories input-dirs
- #:key (separator ":"))
- "Look for each of SUB-DIRECTORIES in INPUT-DIRS. Set ENV-VAR to a
-SEPARATOR-separated path accordingly. Example:
+(define* (set-path-environment-variable env-var files input-dirs
+ #:key
+ (separator ":")
+ (type 'directory)
+ pattern)
+ "Look for each of FILES of the given TYPE (a symbol as returned by
+'stat:type') in INPUT-DIRS. Set ENV-VAR to a SEPARATOR-separated path
+accordingly. Example:
(set-path-environment-variable \"PKG_CONFIG\"
'(\"lib/pkgconfig\")
(list package1 package2))
+
+When PATTERN is not #f, it must be a regular expression (really a string)
+denoting file names to look for under the directories designated by FILES:
+
+ (set-path-environment-variable \"XML_CATALOG_FILES\"
+ '(\"xml\")
+ (list docbook-xml docbook-xsl)
+ #:type 'regular
+ #:pattern \"^catalog\\\\.xml$\")
"
- (let* ((path (search-path-as-list sub-directories input-dirs))
+ (let* ((path (search-path-as-list files input-dirs
+ #:type type
+ #:pattern pattern))
(value (list->search-path-as-string path separator)))
(if (string-null? value)
(begin
;;; 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
((_ after ...)
(append before (alist-cons key value after))))))
+(define-syntax-rule (modify-phases phases mod-spec ...)
+ "Modify PHASES sequentially as per each MOD-SPEC, which may have one of the
+following forms:
+
+ (delete <old-phase-name>)
+ (replace <old-phase-name> <new-phase>)
+ (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 expression evaluating to a symbol, and
+<new-phase> an expression evaluating to a procedure."
+ (let* ((phases* phases)
+ (phases* (%modify-phases phases* mod-spec))
+ ...)
+ phases*))
+
+(define-syntax %modify-phases
+ (syntax-rules (delete replace add-before add-after)
+ ((_ phases (delete old-phase-name))
+ (alist-delete old-phase-name phases))
+ ((_ phases (replace old-phase-name new-phase))
+ (alist-replace old-phase-name new-phase phases))
+ ((_ phases (add-before old-phase-name new-phase-name new-phase))
+ (alist-cons-before old-phase-name new-phase-name new-phase phases))
+ ((_ phases (add-after old-phase-name new-phase-name new-phase))
+ (alist-cons-after old-phase-name new-phase-name new-phase phases))))
+
\f
;;;
;;; Text substitution (aka. sed).
(false-if-exception (delete-file template))))))
(define (substitute file pattern+procs)
- "PATTERN+PROCS is a list of regexp/two-argument procedure. For each line
-of FILE, and for each PATTERN that it matches, call the corresponding PROC
-as (PROC LINE MATCHES); PROC must return the line that will be written as a
-substitution of the original line."
+ "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each
+line of FILE, and for each PATTERN that it matches, call the corresponding
+PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
+a substitution of the original line. Be careful about using '$' to match the
+end of a line; by itself it won't match the terminating newline of a line."
(let ((rx+proc (map (match-lambda
(((? regexp? pattern) . proc)
(cons pattern proc))
match substring.
Alternatively, FILE may be a list of file names, in which case they are
-all subject to the substitutions."
+all subject to the substitutions.
+
+Be careful about using '$' to match the end of a line; by itself it won't
+match the terminating newline of a line."
((substitute* file ((regexp match-var ...) body ...) ...)
(let ()
(define (substitute-one-file file-name)
(define* (dump-port in out
#:key (buffer-size 16384)
(progress (lambda (t k) (k))))
- "Read as much data as possible from IN and write it to OUT, using
-chunks of BUFFER-SIZE bytes. Call PROGRESS after each successful
-transfer of BUFFER-SIZE bytes or less, passing it the total number of
-bytes transferred and the continuation of the transfer as a thunk."
+ "Read as much data as possible from IN and write it to OUT, using chunks of
+BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
+transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
+transferred and the continuation of the transfer as a thunk."
(define buffer
(make-bytevector buffer-size))
- (let loop ((total 0)
- (bytes (get-bytevector-n! in buffer 0 buffer-size)))
+ (define (loop total bytes)
(or (eof-object? bytes)
(let ((total (+ total bytes)))
(put-bytevector out buffer 0 bytes)
(progress total
(lambda ()
(loop total
- (get-bytevector-n! in buffer 0 buffer-size))))))))
+ (get-bytevector-n! in buffer 0 buffer-size)))))))
+
+ ;; Make sure PROGRESS is called when we start so that it can measure
+ ;; throughput.
+ (progress 0
+ (lambda ()
+ (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
(define (set-file-time file stat)
"Set the atime/mtime of FILE to that specified by STAT."
(stat:atimensec stat)
(stat:mtimensec stat)))
+(define (get-char* p)
+ ;; We call it `get-char', but that's really a binary version
+ ;; thereof. (The real `get-char' cannot be used here because our
+ ;; bootstrap Guile is hacked to always use UTF-8.)
+ (match (get-u8 p)
+ ((? integer? x) (integer->char x))
+ (x x)))
+
(define patch-shebang
(let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
(lambda* (file
(call-with-ascii-input-file file
(lambda (p)
- (and (eq? #\# (read-char p))
- (eq? #\! (read-char p))
+ (and (eq? #\# (get-char* p))
+ (eq? #\! (get-char* p))
(let ((line (false-if-exception (read-line p))))
(and=> (and line (regexp-exec shebang-rx line))
(lambda (m)
;; XXX: Unlike with `patch-shebang', FILE is always touched.
(define (find-shell name)
- (let ((shell
- (search-path (search-path-as-string->list (getenv "PATH"))
- name)))
+ (let ((shell (which name)))
(unless shell
(format (current-error-port)
"patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%"
shell))
(let ((st (stat file)))
- (substitute* file
- (("^ *SHELL[[:blank:]]*=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$"
- _ dir shell args)
- (let* ((old (string-append dir shell))
- (new (or (find-shell shell) old)))
- (unless (string=? new old)
- (format (current-error-port)
- "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
- file old new))
- (string-append "SHELL = " new args))))
+ ;; Consider FILE is using an 8-bit encoding to avoid errors.
+ (with-fluids ((%default-port-encoding #f))
+ (substitute* file
+ (("^ *SHELL[[:blank:]]*:?=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$"
+ _ dir shell args)
+ (let* ((old (string-append dir shell))
+ (new (or (find-shell shell) old)))
+ (unless (string=? new old)
+ (format (current-error-port)
+ "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
+ file old new))
+ (string-append "SHELL = " new args)))))
(when keep-mtime?
(set-file-time file st))))
+(define* (patch-/usr/bin/file file
+ #:key
+ (file-command (which "file"))
+ (keep-mtime? #t))
+ "Patch occurrences of \"/usr/bin/file\" in FILE, replacing them with
+FILE-COMMAND. When KEEP-MTIME? is true, keep FILE's modification time
+unchanged."
+ (if (not file-command)
+ (format (current-error-port)
+ "patch-/usr/bin/file: warning: \
+no replacement 'file' command, doing nothing~%")
+ (let ((st (stat file)))
+ ;; Consider FILE is using an 8-bit encoding to avoid errors.
+ (with-fluids ((%default-port-encoding #f))
+ (substitute* file
+ (("/usr/bin/file")
+ (begin
+ (format (current-error-port)
+ "patch-/usr/bin/file: ~a: changing `~a' to `~a'~%"
+ file "/usr/bin/file" file-command)
+ file-command))))
+
+ (when keep-mtime?
+ (set-file-time file st)))))
+
(define* (fold-port-matches proc init pattern port
#:optional (unmatched (lambda (_ r) r)))
"Read from PORT character-by-character; for each match against
(map char-set (string->list pattern))
pattern))
- (define (get-char p)
- ;; We call it `get-char', but that's really a binary version
- ;; thereof. (The real `get-char' cannot be used here because our
- ;; bootstrap Guile is hacked to always use UTF-8.)
- (match (get-u8 p)
- ((? integer? x) (integer->char x))
- (x x)))
-
;; Note: we're not really striving for performance here...
(let loop ((chars '())
(pattern initial-pattern)
(matched '())
(result init))
(cond ((null? chars)
- (loop (list (get-char port))
+ (loop (list (get-char* port))
pattern
matched
result))
#!location/of/bin/bash
export PATH=\"/gnu/.../bar/bin\"
export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\"
- exec location/of/.foo-real
+ exec -a $0 location/of/.foo-real \"$@\"
This is useful for scripts that expect particular programs to be in $PATH, for
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")))
- (copy-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\" \"$@\"~%"
- (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
+;;;
+;;; Locales.
+;;;
+
+(define (locale-category->string category)
+ "Return the name of locale category CATEGORY, one of the 'LC_' constants.
+If CATEGORY is a bitwise or of several 'LC_' constants, an approximation is
+returned."
+ (letrec-syntax ((convert (syntax-rules ()
+ ((_)
+ (number->string category))
+ ((_ first rest ...)
+ (if (= first category)
+ (symbol->string 'first)
+ (convert rest ...))))))
+ (convert LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE
+ LC_IDENTIFICATION LC_MEASUREMENT LC_MESSAGES LC_MONETARY
+ LC_NAME LC_NUMERIC LC_PAPER LC_TELEPHONE
+ LC_TIME)))
;;; Local Variables:
;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
HCoop / jackhill / guix / guix.git / blobdiff