diff options
| -rw-r--r-- | bin/cuirass.in | 4 | ||||
| -rw-r--r-- | bin/evaluate.in | 2 | ||||
| -rw-r--r-- | src/cuirass/base.scm | 2 | ||||
| -rw-r--r-- | src/cuirass/utils.scm | 69 | ||||
| -rw-r--r-- | tests/utils.scm | 15 |
5 files changed, 5 insertions, 87 deletions
diff --git a/bin/cuirass.in b/bin/cuirass.in index 7df5ddb..27efaac 100644 --- a/bin/cuirass.in +++ b/bin/cuirass.in @@ -26,7 +26,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (use-modules (cuirass) (cuirass ui) - (cuirass utils) + (guix ui) (ice-9 getopt-long)) (define (show-help) @@ -90,7 +90,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (and specfile (let ((new-specs (save-module-excursion (λ () - (set-current-module (make-user-module)) + (set-current-module (make-user-module '())) (primitive-load specfile))))) (for-each (λ (spec) (db-add-specification db spec)) new-specs))) diff --git a/bin/evaluate.in b/bin/evaluate.in index 8875238..09a785b 100644 --- a/bin/evaluate.in +++ b/bin/evaluate.in @@ -26,9 +26,9 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" ;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>. (use-modules (cuirass) - (cuirass utils) (ice-9 match) (ice-9 pretty-print) + (guix build utils) (guix store)) (define* (main #:optional (args (command-line))) diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index fc3cc1a..58f2be3 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -20,8 +20,8 @@ (define-module (cuirass base) #:use-module (cuirass database) - #:use-module (cuirass utils) #:use-module (gnu packages) + #:use-module (guix build utils) #:use-module (guix derivations) #:use-module (guix store) #:use-module (ice-9 format) diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm index bcd5e12..dbe00a0 100644 --- a/src/cuirass/utils.scm +++ b/src/cuirass/utils.scm @@ -23,12 +23,8 @@ #:use-module (srfi srfi-1) #:export (;; Procedures alist? - mkdir-p - make-user-module - call-with-temporary-directory ;; Macros. - λ* - with-directory-excursion)) + λ*)) (define-syntax-rule (λ* formals body ...) (lambda* formals body ...)) @@ -37,66 +33,3 @@ "Return #t if OBJ is an alist." (and (list? obj) (every pair? obj))) - -(define mkdir-p - (let ((not-slash (char-set-complement (char-set #\/)))) - (λ* (dir #:optional mode) - "Create directory DIR and all its ancestors." - (let ((absolute? (string-prefix? "/" dir))) - (let loop ((components (string-tokenize dir not-slash)) - (root (if absolute? "" "."))) - (match components - ((head tail ...) - (let ((dir-name (string-append root "/" head))) - (catch 'system-error - (λ () - (if mode - (mkdir dir-name mode) - (mkdir dir-name)) - (loop tail dir-name)) - (λ args - ;; On GNU/Hurd we can get EROFS instead of EEXIST here. - ;; Thus, if we get something other than EEXIST, check - ;; whether DIR-NAME exists. See - ;; <https://lists.gnu.org/archive/html/guix-devel/2016-02/msg00049.html>. - (if (or (= EEXIST (system-error-errno args)) - (let ((st (stat dir-name #f))) - (and st (eq? 'directory (stat:type st))))) - (loop tail dir-name) - (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 - (λ () (chdir dir)) - (λ () body ...) - (λ () (chdir init))))) - -(define* (make-user-module #:optional (modules '())) - "Return a new user module with the additional MODULES loaded." - ;; Module in which the machine description file is loaded. - (let ((module (make-fresh-user-module))) - (for-each (lambda (iface) - (module-use! module (resolve-interface iface))) - modules) - module)) - - -;;; -;;; Temporary files. -;;; - -(define (call-with-temporary-directory proc) - "Call PROC with a name of a temporary directory; close the directory and -delete it when leaving the dynamic extent of this call." - (let* ((parent (or (getenv "TMPDIR") "/tmp")) - (tmp-dir (string-append parent "/" (basename (tmpnam))))) - (mkdir-p tmp-dir) - (dynamic-wind - (const #t) - (lambda () - (proc tmp-dir)) - (lambda () - (false-if-exception (rmdir tmp-dir)))))) diff --git a/tests/utils.scm b/tests/utils.scm index 6a14355..d5298c5 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -35,19 +35,4 @@ (not (alist? 'foo)) (not (alist? #:bar)))) -(test-assert "with-directory-excursion" - (let ((old (getcwd)) - (tmp (tmpnam))) - (dynamic-wind - (λ () - (mkdir tmp)) - (λ () - (with-directory-excursion tmp - (dir-1 (getcwd))) - (dir-2 (getcwd)) - (and (string=? (dir-1) tmp) - (string=? (dir-2) old))) - (λ () - (rmdir tmp))))) - (test-end) |