2de207076b
* guile/guix/make.scm (method-cp, install, install-target?): New functions. * make.scm: Use them.
226 lines
8.2 KiB
Scheme
226 lines
8.2 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; 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.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; 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
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (guix shell-utils)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (ice-9 rdelim)
|
||
#:use-module (ice-9 regex)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (rnrs bytevectors)
|
||
#:use-module (rnrs io ports)
|
||
#:export (dump-port
|
||
mkdir-p
|
||
with-directory-excursion
|
||
substitute
|
||
substitute*))
|
||
|
||
;;;
|
||
;;; Directories.
|
||
;;;
|
||
|
||
(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))))
|
||
|
||
(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)))))
|
||
|
||
(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 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))
|
||
|
||
(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)))))))
|
||
|
||
;; 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)))))
|
||
|
||
|
||
;;;
|
||
;;; Text substitution (aka. sed).
|
||
;;;
|
||
|
||
(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"))
|
||
(out (mkstemp! template))
|
||
(mode (stat:mode (stat file))))
|
||
(with-throw-handler #t
|
||
(lambda ()
|
||
(call-with-input-file file
|
||
(lambda (in)
|
||
(let ((result (proc in out)))
|
||
(close out)
|
||
(chmod template mode)
|
||
(rename-file template file)
|
||
result))))
|
||
(lambda (key . args)
|
||
(false-if-exception (delete-file template))))))
|
||
|
||
(define (substitute file pattern+procs)
|
||
"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))
|
||
((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)))))))))
|
||
|
||
|
||
(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 ...))))
|
||
|
||
(define-syntax substitute*
|
||
(syntax-rules ()
|
||
"Substitute REGEXP in FILE by the string returned by BODY. BODY is
|
||
evaluated with each MATCH-VAR bound to the corresponding positional regexp
|
||
sub-expression. For example:
|
||
|
||
(substitute* file
|
||
((\"hello\")
|
||
\"good morning\\n\")
|
||
((\"foo([a-z]+)bar(.*)$\" all letters end)
|
||
(string-append \"baz\" letter end)))
|
||
|
||
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
|
||
match substring.
|
||
|
||
Alternatively, FILE may be a list of file names, in which case they are
|
||
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)
|
||
(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)))))))
|
||
|