diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/build/utils.scm | 118 | ||||
| -rw-r--r-- | tests/build-utils.scm | 58 |
3 files changed, 176 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index 6b86fb7d46..940736db60 100644 --- a/Makefile.am +++ b/Makefile.am @@ -42,6 +42,7 @@ TESTS = \ tests/builders.scm \ tests/derivations.scm \ tests/utils.scm \ + tests/build-utils.scm \ tests/packages.scm TESTS_ENVIRONMENT = \ diff --git a/guix/build/utils.scm b/guix/build/utils.scm index ccc8a4f6e3..305ce7d4ee 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -18,8 +18,22 @@ (define-module (guix build utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) #:export (directory-exists? - set-path-environment-variable)) + with-directory-excursion + set-path-environment-variable + alist-cons-before + alist-cons-after + alist-replace + substitute)) + + +;;; +;;; Directories. +;;; (define (directory-exists? dir) "Return #t if DIR exists and is a directory." @@ -27,6 +41,22 @@ (and s (eq? 'directory (stat:type s))))) +(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))))) + + +;;; +;;; 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: @@ -62,3 +92,89 @@ SEPARATOR-separated path accordingly. Example: (list->search-path-as-string (search-path-as-list sub-directories input-dirs) separator))) + + +;;; +;;; 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). +;;; + +(define (substitute file pattern match-proc) + "For each line of FILE that matches PATTERN, a regexp, call (MATCH-PROC +MATCH OUTPUT-PORT)." + (let* ((regexp (if (regexp? pattern) + pattern + (make-regexp pattern regexp/extended))) + (template (string-append file ".XXXXXX")) + (out (mkstemp! template))) + (with-throw-handler #t + (lambda () + (call-with-input-file file + (lambda (in) + (let loop ((line (read-line in))) + (if (eof-object? line) + #t + (begin + (cond ((regexp-exec regexp line) + => + (lambda (m) + (match-proc m out))) + (else + (display line out) + (newline out))) + (loop (read-line in))))))) + (rename-file template file)) + (lambda (key . args) + (false-if-exception (delete-file template)))))) + +;;; Local Variables: +;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1) +;;; eval: (put 'with-throw-handler 'scheme-indent-function 1) +;;; End: diff --git a/tests/build-utils.scm b/tests/build-utils.scm new file mode 100644 index 0000000000..4d86037708 --- /dev/null +++ b/tests/build-utils.scm @@ -0,0 +1,58 @@ +;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- +;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of Guix. +;;; +;;; 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. +;;; +;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>. + + +(define-module (test-build-utils) + #:use-module (guix build utils) + #:use-module (srfi srfi-64)) + +(test-begin "build-utils") + +(test-equal "alist-cons-before" + '((a . 1) (x . 42) (b . 2) (c . 3)) + (alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3)))) + +(test-equal "alist-cons-before, reference not found" + '((a . 1) (b . 2) (c . 3) (x . 42)) + (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3)))) + +(test-equal "alist-cons-after" + '((a . 1) (b . 2) (x . 42) (c . 3)) + (alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3)))) + +(test-equal "alist-cons-after, reference not found" + '((a . 1) (b . 2) (c . 3) (x . 42)) + (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3)))) + +(test-equal "alist-replace" + '((a . 1) (b . 77) (c . 3)) + (alist-replace 'b 77 '((a . 1) (b . 2) (c . 3)))) + +(test-assert "alist-replace, key not found" + (not (false-if-exception + (alist-replace 'z 77 '((a . 1) (b . 2) (c . 3)))))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;;; Local Variables: +;;; eval: (put 'test-assert 'scheme-indent-function 1) +;;; eval: (put 'test-equal 'scheme-indent-function 1) +;;; End: |