diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/cuirass/base.scm | 17 | ||||
| -rw-r--r-- | src/cuirass/utils.scm | 65 |
2 files changed, 67 insertions, 15 deletions
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index 63e1b7a..8e6ea36 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -1,6 +1,6 @@ ;;;; base.scm - Cuirass base module ;;; -;;; Copyright © 2012, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of Cuirass. @@ -25,9 +25,7 @@ guix-variable call-with-time-display ;; Parameters. - %program-name - ;; Macros. - with-directory-excursion)) + %program-name)) (define %program-name ;; Similar in spirit to Gnulib 'progname' module. @@ -47,17 +45,6 @@ fails in our case, leading to the creation of empty (guix ...) modules." (let ((m (resolve-interface `(guix ,module)))) (module-ref m name))) -(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 (call-with-time thunk kont) "Call THUNK and pass KONT the elapsed time followed by THUNK's return values." diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm new file mode 100644 index 0000000..48c4b12 --- /dev/null +++ b/src/cuirass/utils.scm @@ -0,0 +1,65 @@ +;;;; utils.scm -- helper procedures +;;; +;;; Copyright © 2012, 2013, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> +;;; +;;; This file is part of Cuirass. +;;; +;;; Cuirass 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. +;;; +;;; Cuirass 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 Cuirass. If not, see <http://www.gnu.org/licenses/>. + +(define-module (cuirass utils) + #:use-module (ice-9 match) + #:export (;; Procedures + mkdir-p + ;; Macros. + with-directory-excursion)) + +(define mkdir-p + (let ((not-slash (char-set-complement (char-set #\/)))) + (lambda* (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 + (lambda () + (if mode + (mkdir dir-name mode) + (mkdir dir-name)) + (loop tail dir-name)) + (lambda 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 + (lambda () + (chdir dir)) + (lambda () + body ...) + (lambda () + (chdir init))))) |