2013-01-05 16:08:07 +01:00
|
|
|
|
;;; GNU Guix --- Functional package management for GNU
|
2014-03-10 23:51:31 +01:00
|
|
|
|
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
|
2013-02-22 23:00:41 +01:00
|
|
|
|
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
|
2013-03-04 00:20:28 +01:00
|
|
|
|
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
|
2012-06-13 17:03:34 +02:00
|
|
|
|
;;;
|
2013-01-05 16:08:07 +01:00
|
|
|
|
;;; This file is part of GNU Guix.
|
2012-06-13 17:03:34 +02:00
|
|
|
|
;;;
|
2013-01-05 16:08:07 +01:00
|
|
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
2012-06-13 17:03:34 +02:00
|
|
|
|
;;; under the terms of the GNU General Public License as published by
|
|
|
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
|
|
|
;;; your option) any later version.
|
|
|
|
|
;;;
|
2013-01-05 16:08:07 +01:00
|
|
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
2012-06-13 17:03:34 +02:00
|
|
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
;;; GNU General Public License for more details.
|
|
|
|
|
;;;
|
|
|
|
|
;;; You should have received a copy of the GNU General Public License
|
2013-01-05 16:08:07 +01:00
|
|
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
2012-06-13 17:03:34 +02:00
|
|
|
|
|
|
|
|
|
(define-module (guix build utils)
|
|
|
|
|
#:use-module (srfi srfi-1)
|
2012-07-01 17:32:03 +02:00
|
|
|
|
#:use-module (srfi srfi-11)
|
2012-10-17 23:06:17 +02:00
|
|
|
|
#:use-module (ice-9 ftw)
|
2012-07-01 17:32:03 +02:00
|
|
|
|
#:use-module (ice-9 match)
|
|
|
|
|
#:use-module (ice-9 regex)
|
|
|
|
|
#:use-module (ice-9 rdelim)
|
2012-08-19 16:44:08 +02:00
|
|
|
|
#:use-module (rnrs bytevectors)
|
|
|
|
|
#:use-module (rnrs io ports)
|
2013-07-03 23:08:41 +02:00
|
|
|
|
#:re-export (alist-cons
|
|
|
|
|
alist-delete)
|
2014-03-10 23:51:31 +01:00
|
|
|
|
#:export (%store-directory
|
|
|
|
|
directory-exists?
|
2012-12-15 16:35:26 +01:00
|
|
|
|
executable-file?
|
2012-12-21 22:31:25 +01:00
|
|
|
|
call-with-ascii-input-file
|
2012-07-01 17:32:03 +02:00
|
|
|
|
with-directory-excursion
|
2012-10-17 22:51:08 +02:00
|
|
|
|
mkdir-p
|
2012-10-17 23:06:17 +02:00
|
|
|
|
copy-recursively
|
2013-03-05 18:53:53 +01:00
|
|
|
|
delete-file-recursively
|
2012-10-17 23:17:15 +02:00
|
|
|
|
find-files
|
|
|
|
|
|
2012-07-01 17:32:03 +02:00
|
|
|
|
set-path-environment-variable
|
2012-08-19 16:44:08 +02:00
|
|
|
|
search-path-as-string->list
|
|
|
|
|
list->search-path-as-string
|
2013-01-05 16:02:32 +01:00
|
|
|
|
which
|
|
|
|
|
|
2012-07-01 17:32:03 +02:00
|
|
|
|
alist-cons-before
|
|
|
|
|
alist-cons-after
|
|
|
|
|
alist-replace
|
2012-10-16 17:28:11 +02:00
|
|
|
|
with-atomic-file-replacement
|
2012-07-07 16:25:10 +02:00
|
|
|
|
substitute
|
2012-08-19 16:44:08 +02:00
|
|
|
|
substitute*
|
|
|
|
|
dump-port
|
2012-12-31 01:17:43 +01:00
|
|
|
|
set-file-time
|
2012-10-16 23:01:01 +02:00
|
|
|
|
patch-shebang
|
2012-12-21 22:31:25 +01:00
|
|
|
|
patch-makefile-SHELL
|
2012-10-16 23:01:01 +02:00
|
|
|
|
fold-port-matches
|
2013-03-04 00:20:28 +01:00
|
|
|
|
remove-store-references
|
|
|
|
|
wrap-program))
|
2012-07-01 17:32:03 +02:00
|
|
|
|
|
2013-02-22 23:00:41 +01:00
|
|
|
|
|
2012-07-01 17:32:03 +02:00
|
|
|
|
;;;
|
|
|
|
|
;;; Directories.
|
|
|
|
|
;;;
|
2012-06-13 17:03:34 +02:00
|
|
|
|
|
2014-03-10 23:51:31 +01:00
|
|
|
|
(define (%store-directory)
|
|
|
|
|
"Return the directory name of the store."
|
|
|
|
|
(or (getenv "NIX_STORE")
|
|
|
|
|
"/gnu/store"))
|
|
|
|
|
|
2012-06-13 17:03:34 +02:00
|
|
|
|
(define (directory-exists? dir)
|
|
|
|
|
"Return #t if DIR exists and is a directory."
|
2012-06-16 16:16:16 +02:00
|
|
|
|
(let ((s (stat dir #f)))
|
|
|
|
|
(and s
|
|
|
|
|
(eq? 'directory (stat:type s)))))
|
2012-06-13 17:03:34 +02:00
|
|
|
|
|
2012-12-15 16:35:26 +01:00
|
|
|
|
(define (executable-file? file)
|
|
|
|
|
"Return #t if FILE exists and is executable."
|
|
|
|
|
(let ((s (stat file #f)))
|
|
|
|
|
(and s
|
|
|
|
|
(not (zero? (logand (stat:mode s) #o100))))))
|
|
|
|
|
|
2012-12-21 22:31:25 +01:00
|
|
|
|
(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
|
|
|
|
|
return values of applying PROC to the port."
|
|
|
|
|
(let ((port (with-fluids ((%default-port-encoding #f))
|
|
|
|
|
;; Use "b" so that `open-file' ignores `coding:' cookies.
|
|
|
|
|
(open-file file "rb"))))
|
|
|
|
|
(dynamic-wind
|
|
|
|
|
(lambda ()
|
|
|
|
|
#t)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(proc port))
|
|
|
|
|
(lambda ()
|
|
|
|
|
(close-input-port port)))))
|
|
|
|
|
|
2012-07-01 17:32:03 +02:00
|
|
|
|
(define-syntax-rule (with-directory-excursion dir body ...)
|
|
|
|
|
"Run BODY with DIR as the process's current directory."
|
|
|
|
|
(let ((init (getcwd)))
|
|
|
|
|
(dynamic-wind
|
|
|
|
|
(lambda ()
|
|
|
|
|
(chdir dir))
|
|
|
|
|
(lambda ()
|
|
|
|
|
body ...)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(chdir init)))))
|
|
|
|
|
|
2012-10-17 22:51:08 +02:00
|
|
|
|
(define (mkdir-p dir)
|
|
|
|
|
"Create directory DIR and all its ancestors."
|
|
|
|
|
(define absolute?
|
|
|
|
|
(string-prefix? "/" dir))
|
|
|
|
|
|
|
|
|
|
(define not-slash
|
|
|
|
|
(char-set-complement (char-set #\/)))
|
|
|
|
|
|
|
|
|
|
(let loop ((components (string-tokenize dir not-slash))
|
|
|
|
|
(root (if absolute?
|
|
|
|
|
""
|
|
|
|
|
".")))
|
|
|
|
|
(match components
|
|
|
|
|
((head tail ...)
|
|
|
|
|
(let ((path (string-append root "/" head)))
|
|
|
|
|
(catch 'system-error
|
|
|
|
|
(lambda ()
|
|
|
|
|
(mkdir path)
|
|
|
|
|
(loop tail path))
|
|
|
|
|
(lambda args
|
|
|
|
|
(if (= EEXIST (system-error-errno args))
|
|
|
|
|
(loop tail path)
|
|
|
|
|
(apply throw args))))))
|
|
|
|
|
(() #t))))
|
|
|
|
|
|
2012-10-17 23:06:17 +02:00
|
|
|
|
(define* (copy-recursively source destination
|
2013-03-05 19:03:39 +01:00
|
|
|
|
#:key
|
|
|
|
|
(log (current-output-port))
|
|
|
|
|
(follow-symlinks? #f))
|
|
|
|
|
"Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS?
|
|
|
|
|
is true; otherwise, just preserve them. Write verbose output to the LOG port."
|
2012-10-17 23:06:17 +02:00
|
|
|
|
(define strip-source
|
|
|
|
|
(let ((len (string-length source)))
|
|
|
|
|
(lambda (file)
|
|
|
|
|
(substring file len))))
|
|
|
|
|
|
|
|
|
|
(file-system-fold (const #t) ; enter?
|
|
|
|
|
(lambda (file stat result) ; leaf
|
|
|
|
|
(let ((dest (string-append destination
|
|
|
|
|
(strip-source file))))
|
|
|
|
|
(format log "`~a' -> `~a'~%" file dest)
|
2013-03-05 19:03:39 +01:00
|
|
|
|
(case (stat:type stat)
|
|
|
|
|
((symlink)
|
|
|
|
|
(let ((target (readlink file)))
|
|
|
|
|
(symlink target dest)))
|
|
|
|
|
(else
|
|
|
|
|
(copy-file file dest)))))
|
2012-10-17 23:06:17 +02:00
|
|
|
|
(lambda (dir stat result) ; down
|
|
|
|
|
(mkdir-p (string-append destination
|
|
|
|
|
(strip-source dir))))
|
|
|
|
|
(lambda (dir stat result) ; up
|
|
|
|
|
result)
|
|
|
|
|
(const #t) ; skip
|
|
|
|
|
(lambda (file stat errno result)
|
|
|
|
|
(format (current-error-port) "i/o error: ~a: ~a~%"
|
|
|
|
|
file (strerror errno))
|
|
|
|
|
#f)
|
|
|
|
|
#t
|
2013-03-05 19:03:39 +01:00
|
|
|
|
source
|
|
|
|
|
|
|
|
|
|
(if follow-symlinks?
|
|
|
|
|
stat
|
|
|
|
|
lstat)))
|
2012-10-17 23:06:17 +02:00
|
|
|
|
|
2013-03-05 18:53:53 +01:00
|
|
|
|
(define (delete-file-recursively dir)
|
|
|
|
|
"Delete DIR recursively, like `rm -rf', without following symlinks. Report
|
|
|
|
|
but ignore errors."
|
|
|
|
|
(file-system-fold (const #t) ; enter?
|
|
|
|
|
(lambda (file stat result) ; leaf
|
|
|
|
|
(delete-file file))
|
|
|
|
|
(const #t) ; down
|
|
|
|
|
(lambda (dir stat result) ; up
|
|
|
|
|
(rmdir dir))
|
|
|
|
|
(const #t) ; skip
|
|
|
|
|
(lambda (file stat errno result)
|
|
|
|
|
(format (current-error-port)
|
|
|
|
|
"warning: failed to delete ~a: ~a~%"
|
|
|
|
|
file (strerror errno)))
|
|
|
|
|
#t
|
|
|
|
|
dir
|
|
|
|
|
|
|
|
|
|
;; Don't follow symlinks.
|
|
|
|
|
lstat))
|
|
|
|
|
|
2012-10-17 23:17:15 +02:00
|
|
|
|
(define (find-files dir regexp)
|
2013-09-15 23:20:16 +02:00
|
|
|
|
"Return the lexicographically sorted list of files under DIR whose basename
|
|
|
|
|
matches REGEXP."
|
2012-10-17 23:17:15 +02:00
|
|
|
|
(define file-rx
|
|
|
|
|
(if (regexp? regexp)
|
|
|
|
|
regexp
|
|
|
|
|
(make-regexp regexp)))
|
|
|
|
|
|
2013-09-15 23:20:16 +02:00
|
|
|
|
;; 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))
|
2013-10-16 15:53:59 +02:00
|
|
|
|
result)
|
2013-09-15 23:20:16 +02:00
|
|
|
|
'()
|
|
|
|
|
dir)
|
|
|
|
|
string<?))
|
2012-10-17 23:17:15 +02:00
|
|
|
|
|
2012-07-01 17:32:03 +02:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Search paths.
|
|
|
|
|
;;;
|
|
|
|
|
|
2012-06-13 17:03:34 +02:00
|
|
|
|
(define (search-path-as-list sub-directories input-dirs)
|
|
|
|
|
"Return the list of directories among SUB-DIRECTORIES 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\")
|
|
|
|
|
|
|
|
|
|
"
|
|
|
|
|
(append-map (lambda (input)
|
|
|
|
|
(filter-map (lambda (dir)
|
|
|
|
|
(let ((dir (string-append input "/"
|
|
|
|
|
dir)))
|
|
|
|
|
(and (directory-exists? dir)
|
|
|
|
|
dir)))
|
|
|
|
|
sub-directories))
|
|
|
|
|
input-dirs))
|
|
|
|
|
|
|
|
|
|
(define (list->search-path-as-string lst separator)
|
|
|
|
|
(string-join lst separator))
|
|
|
|
|
|
2012-08-19 16:44:08 +02:00
|
|
|
|
(define* (search-path-as-string->list path #:optional (separator #\:))
|
|
|
|
|
(string-tokenize path (char-set-complement (char-set separator))))
|
|
|
|
|
|
2012-06-13 17:03:34 +02:00
|
|
|
|
(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:
|
|
|
|
|
|
|
|
|
|
(set-path-environment-variable \"PKG_CONFIG\"
|
|
|
|
|
'(\"lib/pkgconfig\")
|
|
|
|
|
(list package1 package2))
|
|
|
|
|
"
|
2012-09-06 22:57:46 +02:00
|
|
|
|
(let* ((path (search-path-as-list sub-directories input-dirs))
|
|
|
|
|
(value (list->search-path-as-string path separator)))
|
2013-06-22 16:42:46 +02:00
|
|
|
|
(if (string-null? value)
|
|
|
|
|
(begin
|
|
|
|
|
;; Never set ENV-VAR to an empty string because often, the empty
|
|
|
|
|
;; string is equivalent to ".". This is the case for
|
|
|
|
|
;; GUILE_LOAD_PATH in Guile 2.0, for instance.
|
|
|
|
|
(unsetenv env-var)
|
|
|
|
|
(format #t "environment variable `~a' unset~%" env-var))
|
|
|
|
|
(begin
|
|
|
|
|
(setenv env-var value)
|
|
|
|
|
(format #t "environment variable `~a' set to `~a'~%"
|
|
|
|
|
env-var value)))))
|
2012-07-01 17:32:03 +02:00
|
|
|
|
|
2013-01-05 16:02:32 +01:00
|
|
|
|
(define (which program)
|
|
|
|
|
"Return the complete file name for PROGRAM as found in $PATH, or #f if
|
|
|
|
|
PROGRAM could not be found."
|
|
|
|
|
(search-path (search-path-as-string->list (getenv "PATH"))
|
|
|
|
|
program))
|
|
|
|
|
|
2012-07-01 17:32:03 +02:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Phases.
|
|
|
|
|
;;;
|
|
|
|
|
;;; In (guix build gnu-build-system), there are separate phases (configure,
|
|
|
|
|
;;; build, test, install). They are represented as a list of name/procedure
|
|
|
|
|
;;; pairs. The following procedures make it easy to change the list of
|
|
|
|
|
;;; phases.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(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
|
|
|
|
|
is REFERENCE in ALIST. Use KEY=? to compare keys."
|
|
|
|
|
(let-values (((before after)
|
|
|
|
|
(break (match-lambda
|
|
|
|
|
((k . _)
|
|
|
|
|
(key=? k reference)))
|
|
|
|
|
alist)))
|
|
|
|
|
(append before (alist-cons key value after))))
|
|
|
|
|
|
|
|
|
|
(define* (alist-cons-after reference key value alist
|
|
|
|
|
#:optional (key=? equal?))
|
|
|
|
|
"Insert the KEY/VALUE pair after the first occurrence of a pair whose key
|
|
|
|
|
is REFERENCE in ALIST. Use KEY=? to compare keys."
|
|
|
|
|
(let-values (((before after)
|
|
|
|
|
(break (match-lambda
|
|
|
|
|
((k . _)
|
|
|
|
|
(key=? k reference)))
|
|
|
|
|
alist)))
|
|
|
|
|
(match after
|
|
|
|
|
((reference after ...)
|
|
|
|
|
(append before (cons* reference `(,key . ,value) after)))
|
|
|
|
|
(()
|
|
|
|
|
(append before `((,key . ,value)))))))
|
|
|
|
|
|
|
|
|
|
(define* (alist-replace key value alist #:optional (key=? equal?))
|
|
|
|
|
"Replace the first pair in ALIST whose car is KEY with the KEY/VALUE pair.
|
|
|
|
|
An error is raised when no such pair exists."
|
|
|
|
|
(let-values (((before after)
|
|
|
|
|
(break (match-lambda
|
|
|
|
|
((k . _)
|
|
|
|
|
(key=? k key)))
|
|
|
|
|
alist)))
|
|
|
|
|
(match after
|
|
|
|
|
((_ after ...)
|
|
|
|
|
(append before (alist-cons key value after))))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Text substitution (aka. sed).
|
|
|
|
|
;;;
|
|
|
|
|
|
2012-10-16 17:28:11 +02:00
|
|
|
|
(define (with-atomic-file-replacement file proc)
|
|
|
|
|
"Call PROC with two arguments: an input port for FILE, and an output
|
|
|
|
|
port for the file that is going to replace FILE. Upon success, FILE is
|
|
|
|
|
atomically replaced by what has been written to the output port, and
|
|
|
|
|
PROC's result is returned."
|
|
|
|
|
(let* ((template (string-append file ".XXXXXX"))
|
2012-07-07 18:11:52 +02:00
|
|
|
|
(out (mkstemp! template))
|
|
|
|
|
(mode (stat:mode (stat file))))
|
2012-07-01 17:32:03 +02:00
|
|
|
|
(with-throw-handler #t
|
|
|
|
|
(lambda ()
|
|
|
|
|
(call-with-input-file file
|
|
|
|
|
(lambda (in)
|
2012-10-16 17:28:11 +02:00
|
|
|
|
(let ((result (proc in out)))
|
|
|
|
|
(close out)
|
|
|
|
|
(chmod template mode)
|
|
|
|
|
(rename-file template file)
|
|
|
|
|
result))))
|
2012-07-01 17:32:03 +02:00
|
|
|
|
(lambda (key . args)
|
|
|
|
|
(false-if-exception (delete-file template))))))
|
|
|
|
|
|
2012-10-16 17:28:11 +02:00
|
|
|
|
(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."
|
|
|
|
|
(let ((rx+proc (map (match-lambda
|
|
|
|
|
(((? regexp? pattern) . proc)
|
|
|
|
|
(cons pattern proc))
|
|
|
|
|
((pattern . proc)
|
|
|
|
|
(cons (make-regexp pattern regexp/extended)
|
|
|
|
|
proc)))
|
|
|
|
|
pattern+procs)))
|
|
|
|
|
(with-atomic-file-replacement file
|
|
|
|
|
(lambda (in out)
|
|
|
|
|
(let loop ((line (read-line in 'concat)))
|
|
|
|
|
(if (eof-object? line)
|
|
|
|
|
#t
|
|
|
|
|
(let ((line (fold (lambda (r+p line)
|
|
|
|
|
(match r+p
|
|
|
|
|
((regexp . proc)
|
|
|
|
|
(match (list-matches regexp line)
|
|
|
|
|
((and m+ (_ _ ...))
|
|
|
|
|
(proc line m+))
|
|
|
|
|
(_ line)))))
|
|
|
|
|
line
|
|
|
|
|
rx+proc)))
|
|
|
|
|
(display line out)
|
|
|
|
|
(loop (read-line in 'concat)))))))))
|
|
|
|
|
|
2012-07-07 16:25:10 +02:00
|
|
|
|
|
|
|
|
|
(define-syntax let-matches
|
|
|
|
|
;; Helper macro for `substitute*'.
|
|
|
|
|
(syntax-rules (_)
|
|
|
|
|
((let-matches index match (_ vars ...) body ...)
|
|
|
|
|
(let-matches (+ 1 index) match (vars ...)
|
|
|
|
|
body ...))
|
|
|
|
|
((let-matches index match (var vars ...) body ...)
|
|
|
|
|
(let ((var (match:substring match index)))
|
|
|
|
|
(let-matches (+ 1 index) match (vars ...)
|
|
|
|
|
body ...)))
|
|
|
|
|
((let-matches index match () body ...)
|
|
|
|
|
(begin body ...))))
|
|
|
|
|
|
2012-08-25 13:12:33 +02:00
|
|
|
|
(define-syntax substitute*
|
|
|
|
|
(syntax-rules ()
|
|
|
|
|
"Substitute REGEXP in FILE by the string returned by BODY. BODY is
|
2012-07-07 16:25:10 +02:00
|
|
|
|
evaluated with each MATCH-VAR bound to the corresponding positional regexp
|
|
|
|
|
sub-expression. For example:
|
|
|
|
|
|
2012-07-07 17:12:04 +02:00
|
|
|
|
(substitute* file
|
2012-10-26 09:07:37 +02:00
|
|
|
|
((\"hello\")
|
|
|
|
|
\"good morning\\n\")
|
|
|
|
|
((\"foo([a-z]+)bar(.*)$\" all letters end)
|
|
|
|
|
(string-append \"baz\" letter end)))
|
2012-07-07 17:12:04 +02:00
|
|
|
|
|
|
|
|
|
Here, anytime a line of FILE contains \"hello\", it is replaced by \"good
|
|
|
|
|
morning\". Anytime a line of FILE matches the second regexp, ALL is bound to
|
|
|
|
|
the complete match, LETTERS is bound to the first sub-expression, and END is
|
|
|
|
|
bound to the last one.
|
|
|
|
|
|
|
|
|
|
When one of the MATCH-VAR is `_', no variable is bound to the corresponding
|
2012-10-26 09:07:37 +02:00
|
|
|
|
match substring.
|
|
|
|
|
|
|
|
|
|
Alternatively, FILE may be a list of file names, in which case they are
|
|
|
|
|
all subject to the substitutions."
|
2012-08-25 13:12:33 +02:00
|
|
|
|
((substitute* file ((regexp match-var ...) body ...) ...)
|
2012-10-26 09:07:37 +02:00
|
|
|
|
(let ()
|
|
|
|
|
(define (substitute-one-file file-name)
|
|
|
|
|
(substitute
|
|
|
|
|
file-name
|
|
|
|
|
(list (cons regexp
|
|
|
|
|
(lambda (l m+)
|
|
|
|
|
;; Iterate over matches M+ and return the
|
|
|
|
|
;; modified line based on L.
|
|
|
|
|
(let loop ((m* m+) ; matches
|
|
|
|
|
(o 0) ; offset in L
|
|
|
|
|
(r '())) ; result
|
|
|
|
|
(match m*
|
|
|
|
|
(()
|
|
|
|
|
(let ((r (cons (substring l o) r)))
|
|
|
|
|
(string-concatenate-reverse r)))
|
|
|
|
|
((m . rest)
|
|
|
|
|
(let-matches 0 m (match-var ...)
|
|
|
|
|
(loop rest
|
|
|
|
|
(match:end m)
|
|
|
|
|
(cons*
|
|
|
|
|
(begin body ...)
|
|
|
|
|
(substring l o (match:start m))
|
|
|
|
|
r))))))))
|
|
|
|
|
...)))
|
|
|
|
|
|
|
|
|
|
(match file
|
|
|
|
|
((files (... ...))
|
|
|
|
|
(for-each substitute-one-file files))
|
|
|
|
|
((? string? f)
|
|
|
|
|
(substitute-one-file f)))))))
|
2012-07-07 16:25:10 +02:00
|
|
|
|
|
2012-08-19 16:44:08 +02:00
|
|
|
|
|
|
|
|
|
;;;
|
2014-03-10 23:51:31 +01:00
|
|
|
|
;;; Patching shebangs---e.g., /bin/sh -> /gnu/store/xyz...-bash/bin/sh.
|
2012-08-19 16:44:08 +02:00
|
|
|
|
;;;
|
|
|
|
|
|
2012-12-20 01:34:42 +01:00
|
|
|
|
(define* (dump-port in out
|
|
|
|
|
#:key (buffer-size 16384)
|
|
|
|
|
(progress (lambda (t k) (k))))
|
2012-12-15 15:54:29 +01:00
|
|
|
|
"Read as much data as possible from IN and write it to OUT, using
|
2012-12-20 01:34:42 +01:00
|
|
|
|
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."
|
2012-08-19 16:44:08 +02:00
|
|
|
|
(define buffer
|
|
|
|
|
(make-bytevector buffer-size))
|
|
|
|
|
|
2012-12-20 01:34:42 +01:00
|
|
|
|
(let loop ((total 0)
|
|
|
|
|
(bytes (get-bytevector-n! in buffer 0 buffer-size)))
|
2012-08-19 16:44:08 +02:00
|
|
|
|
(or (eof-object? bytes)
|
2012-12-20 01:34:42 +01:00
|
|
|
|
(let ((total (+ total bytes)))
|
2012-08-19 16:44:08 +02:00
|
|
|
|
(put-bytevector out buffer 0 bytes)
|
2012-12-20 01:34:42 +01:00
|
|
|
|
(progress total
|
|
|
|
|
(lambda ()
|
|
|
|
|
(loop total
|
|
|
|
|
(get-bytevector-n! in buffer 0 buffer-size))))))))
|
2012-08-19 16:44:08 +02:00
|
|
|
|
|
2012-12-31 01:17:43 +01:00
|
|
|
|
(define (set-file-time file stat)
|
|
|
|
|
"Set the atime/mtime of FILE to that specified by STAT."
|
|
|
|
|
(utime file
|
|
|
|
|
(stat:atime stat)
|
|
|
|
|
(stat:mtime stat)
|
|
|
|
|
(stat:atimensec stat)
|
|
|
|
|
(stat:mtimensec stat)))
|
|
|
|
|
|
2012-08-19 16:44:08 +02:00
|
|
|
|
(define patch-shebang
|
2013-02-22 23:00:41 +01:00
|
|
|
|
(let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
|
2012-08-19 21:50:03 +02:00
|
|
|
|
(lambda* (file
|
2012-12-31 01:17:43 +01:00
|
|
|
|
#:optional
|
|
|
|
|
(path (search-path-as-string->list (getenv "PATH")))
|
|
|
|
|
#:key (keep-mtime? #t))
|
2012-08-19 21:50:03 +02:00
|
|
|
|
"Replace the #! interpreter file name in FILE by a valid one found in
|
|
|
|
|
PATH, when FILE actually starts with a shebang. Return #t when FILE was
|
2012-12-31 01:17:43 +01:00
|
|
|
|
patched, #f otherwise. When KEEP-MTIME? is true, the atime/mtime of
|
|
|
|
|
FILE are kept unchanged."
|
2012-08-19 16:44:08 +02:00
|
|
|
|
(define (patch p interpreter rest-of-line)
|
|
|
|
|
(let* ((template (string-append file ".XXXXXX"))
|
|
|
|
|
(out (mkstemp! template))
|
2012-12-31 01:17:43 +01:00
|
|
|
|
(st (stat file))
|
|
|
|
|
(mode (stat:mode st)))
|
2012-08-19 16:44:08 +02:00
|
|
|
|
(with-throw-handler #t
|
|
|
|
|
(lambda ()
|
|
|
|
|
(format out "#!~a~a~%"
|
|
|
|
|
interpreter rest-of-line)
|
|
|
|
|
(dump-port p out)
|
|
|
|
|
(close out)
|
|
|
|
|
(chmod template mode)
|
|
|
|
|
(rename-file template file)
|
2012-12-31 01:17:43 +01:00
|
|
|
|
(when keep-mtime?
|
|
|
|
|
(set-file-time file st))
|
2012-08-19 16:44:08 +02:00
|
|
|
|
#t)
|
|
|
|
|
(lambda (key . args)
|
|
|
|
|
(format (current-error-port)
|
|
|
|
|
"patch-shebang: ~a: error: ~a ~s~%"
|
|
|
|
|
file key args)
|
|
|
|
|
(false-if-exception (delete-file template))
|
|
|
|
|
#f))))
|
|
|
|
|
|
2012-12-21 22:31:25 +01:00
|
|
|
|
(call-with-ascii-input-file file
|
|
|
|
|
(lambda (p)
|
|
|
|
|
(and (eq? #\# (read-char p))
|
|
|
|
|
(eq? #\! (read-char p))
|
|
|
|
|
(let ((line (false-if-exception (read-line p))))
|
|
|
|
|
(and=> (and line (regexp-exec shebang-rx line))
|
|
|
|
|
(lambda (m)
|
2013-02-22 23:00:41 +01:00
|
|
|
|
(let* ((interp (match:substring m 1))
|
|
|
|
|
(arg1 (match:substring m 2))
|
|
|
|
|
(rest (match:substring m 3))
|
|
|
|
|
(has-env (string-suffix? "/env" interp))
|
|
|
|
|
(cmd (if has-env arg1 (basename interp)))
|
|
|
|
|
(bin (search-path path cmd)))
|
2012-12-21 22:31:25 +01:00
|
|
|
|
(if bin
|
2013-02-22 23:00:41 +01:00
|
|
|
|
(if (string=? bin interp)
|
2012-12-21 22:31:25 +01:00
|
|
|
|
#f ; nothing to do
|
2013-02-22 23:00:41 +01:00
|
|
|
|
(if has-env
|
|
|
|
|
(begin
|
|
|
|
|
(format (current-error-port)
|
|
|
|
|
"patch-shebang: ~a: changing `~a' to `~a'~%"
|
|
|
|
|
file (string-append interp " " arg1) bin)
|
|
|
|
|
(patch p bin rest))
|
|
|
|
|
(begin
|
|
|
|
|
(format (current-error-port)
|
|
|
|
|
"patch-shebang: ~a: changing `~a' to `~a'~%"
|
|
|
|
|
file interp bin)
|
|
|
|
|
(patch p bin
|
2013-02-23 23:27:46 +01:00
|
|
|
|
(if (string-null? arg1)
|
|
|
|
|
""
|
|
|
|
|
(string-append " " arg1 rest))))))
|
2012-12-21 22:31:25 +01:00
|
|
|
|
(begin
|
|
|
|
|
(format (current-error-port)
|
|
|
|
|
"patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%"
|
|
|
|
|
file (basename cmd))
|
|
|
|
|
#f))))))))))))
|
|
|
|
|
|
2012-12-31 01:17:43 +01:00
|
|
|
|
(define* (patch-makefile-SHELL file #:key (keep-mtime? #t))
|
|
|
|
|
"Patch the `SHELL' variable in FILE, which is supposedly a makefile.
|
|
|
|
|
When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged."
|
2012-12-21 22:31:25 +01:00
|
|
|
|
|
|
|
|
|
;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL.
|
|
|
|
|
|
|
|
|
|
;; 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)))
|
|
|
|
|
(unless shell
|
|
|
|
|
(format (current-error-port)
|
|
|
|
|
"patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%"
|
|
|
|
|
name))
|
|
|
|
|
shell))
|
|
|
|
|
|
2012-12-31 01:17:43 +01:00
|
|
|
|
(let ((st (stat file)))
|
|
|
|
|
(substitute* file
|
|
|
|
|
(("^ *SHELL[[:blank:]]*=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)[[:blank:]]*" _ dir shell)
|
|
|
|
|
(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 "\n"))))
|
|
|
|
|
|
|
|
|
|
(when keep-mtime?
|
|
|
|
|
(set-file-time file st))))
|
2012-07-07 16:25:10 +02:00
|
|
|
|
|
2012-10-16 23:01:01 +02:00
|
|
|
|
(define* (fold-port-matches proc init pattern port
|
|
|
|
|
#:optional (unmatched (lambda (_ r) r)))
|
|
|
|
|
"Read from PORT character-by-character; for each match against
|
|
|
|
|
PATTERN, call (PROC MATCH RESULT), where RESULT is seeded with INIT.
|
|
|
|
|
PATTERN is a list of SRFI-14 char-sets. Call (UNMATCHED CHAR RESULT)
|
|
|
|
|
for each unmatched character."
|
|
|
|
|
(define initial-pattern
|
|
|
|
|
;; The poor developer's regexp.
|
|
|
|
|
(if (string? pattern)
|
|
|
|
|
(map char-set (string->list pattern))
|
|
|
|
|
pattern))
|
|
|
|
|
|
2013-01-01 23:12:34 +01:00
|
|
|
|
(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)))
|
|
|
|
|
|
2012-10-16 23:01:01 +02:00
|
|
|
|
;; 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))
|
|
|
|
|
pattern
|
|
|
|
|
matched
|
|
|
|
|
result))
|
|
|
|
|
((null? pattern)
|
|
|
|
|
(loop chars
|
|
|
|
|
initial-pattern
|
|
|
|
|
'()
|
|
|
|
|
(proc (list->string (reverse matched)) result)))
|
|
|
|
|
((eof-object? (car chars))
|
|
|
|
|
(fold-right unmatched result matched))
|
|
|
|
|
((char-set-contains? (car pattern) (car chars))
|
|
|
|
|
(loop (cdr chars)
|
|
|
|
|
(cdr pattern)
|
|
|
|
|
(cons (car chars) matched)
|
|
|
|
|
result))
|
|
|
|
|
((null? matched) ; common case
|
|
|
|
|
(loop (cdr chars)
|
|
|
|
|
pattern
|
|
|
|
|
matched
|
|
|
|
|
(unmatched (car chars) result)))
|
|
|
|
|
(else
|
|
|
|
|
(let ((matched (reverse matched)))
|
|
|
|
|
(loop (append (cdr matched) chars)
|
|
|
|
|
initial-pattern
|
|
|
|
|
'()
|
|
|
|
|
(unmatched (car matched) result)))))))
|
|
|
|
|
|
|
|
|
|
(define* (remove-store-references file
|
2014-03-10 23:51:31 +01:00
|
|
|
|
#:optional (store (%store-directory)))
|
2012-10-16 23:01:01 +02:00
|
|
|
|
"Remove from FILE occurrences of file names in STORE; return #t when
|
|
|
|
|
store paths were encountered in FILE, #f otherwise. This procedure is
|
|
|
|
|
known as `nuke-refs' in Nixpkgs."
|
|
|
|
|
(define pattern
|
|
|
|
|
(let ((nix-base32-chars
|
|
|
|
|
'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
|
|
|
|
|
#\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
|
|
|
|
|
#\p #\q #\r #\s #\v #\w #\x #\y #\z)))
|
|
|
|
|
`(,@(map char-set (string->list store))
|
|
|
|
|
,(char-set #\/)
|
|
|
|
|
,@(make-list 32 (list->char-set nix-base32-chars))
|
|
|
|
|
,(char-set #\-))))
|
|
|
|
|
|
|
|
|
|
(with-fluids ((%default-port-encoding #f))
|
|
|
|
|
(with-atomic-file-replacement file
|
|
|
|
|
(lambda (in out)
|
|
|
|
|
;; We cannot use `regexp-exec' here because it cannot deal with
|
|
|
|
|
;; strings containing NUL characters.
|
|
|
|
|
(format #t "removing store references from `~a'...~%" file)
|
|
|
|
|
(setvbuf in _IOFBF 65536)
|
|
|
|
|
(setvbuf out _IOFBF 65536)
|
|
|
|
|
(fold-port-matches (lambda (match result)
|
2013-01-01 23:12:34 +01:00
|
|
|
|
(put-bytevector out (string->utf8 store))
|
|
|
|
|
(put-u8 out (char->integer #\/))
|
|
|
|
|
(put-bytevector out
|
|
|
|
|
(string->utf8
|
|
|
|
|
"eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-"))
|
2012-10-16 23:01:01 +02:00
|
|
|
|
#t)
|
|
|
|
|
#f
|
|
|
|
|
pattern
|
|
|
|
|
in
|
|
|
|
|
(lambda (char result)
|
2013-01-01 23:12:34 +01:00
|
|
|
|
(put-u8 out (char->integer char))
|
2012-10-16 23:01:01 +02:00
|
|
|
|
result))))))
|
|
|
|
|
|
2013-03-04 00:20:28 +01:00
|
|
|
|
(define* (wrap-program prog #:rest vars)
|
|
|
|
|
"Rename PROG to .PROG-real and make PROG a wrapper. VARS should look like
|
|
|
|
|
this:
|
|
|
|
|
|
|
|
|
|
'(VARIABLE DELIMITER POSITION LIST-OF-DIRECTORIES)
|
|
|
|
|
|
|
|
|
|
where DELIMITER is optional. ':' will be used if DELIMITER is not given.
|
|
|
|
|
|
|
|
|
|
For example, this command:
|
|
|
|
|
|
|
|
|
|
(wrap-program \"foo\"
|
|
|
|
|
'(\"PATH\" \":\" = (\"/nix/.../bar/bin\"))
|
|
|
|
|
'(\"CERT_PATH\" suffix (\"/nix/.../baz/certs\"
|
|
|
|
|
\"/qux/certs\")))
|
|
|
|
|
|
|
|
|
|
will copy 'foo' to '.foo-real' and create the file 'foo' with the following
|
|
|
|
|
contents:
|
|
|
|
|
|
|
|
|
|
#!location/of/bin/bash
|
|
|
|
|
export PATH=\"/nix/.../bar/bin\"
|
|
|
|
|
export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/nix/.../baz/certs:/qux/certs\"
|
|
|
|
|
exec 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."
|
2013-04-28 18:08:23 +02:00
|
|
|
|
(let ((prog-real (string-append (dirname prog) "/." (basename prog) "-real"))
|
|
|
|
|
(prog-tmp (string-append (dirname prog) "/." (basename prog) "-tmp")))
|
2013-03-04 00:20:28 +01:00
|
|
|
|
(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 ":")))))
|
|
|
|
|
|
|
|
|
|
(copy-file prog prog-real)
|
|
|
|
|
|
|
|
|
|
(with-output-to-file prog-tmp
|
|
|
|
|
(lambda ()
|
|
|
|
|
(format #t
|
2013-04-28 18:08:23 +02:00
|
|
|
|
"#!~a~%~a~%exec \"~a\" \"$@\"~%"
|
2013-03-04 00:20:28 +01:00
|
|
|
|
(which "bash")
|
|
|
|
|
(string-join (map export-variable vars)
|
|
|
|
|
"\n")
|
|
|
|
|
(canonicalize-path prog-real))))
|
|
|
|
|
|
|
|
|
|
(chmod prog-tmp #o755)
|
|
|
|
|
(rename-file prog-tmp prog)))
|
|
|
|
|
|
2012-07-01 17:32:03 +02:00
|
|
|
|
;;; Local Variables:
|
|
|
|
|
;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
|
|
|
|
|
;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
|
2012-09-01 19:21:06 +02:00
|
|
|
|
;;; eval: (put 'let-matches 'scheme-indent-function 3)
|
2012-10-16 17:28:11 +02:00
|
|
|
|
;;; eval: (put 'with-atomic-file-replacement 'scheme-indent-function 1)
|
2012-07-01 17:32:03 +02:00
|
|
|
|
;;; End:
|