Add (cuirass utils) module.

Move 'with-directory-excursion' here.

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)))))