From 2bace101060afb48f8eb45e848dacb5761b2151b Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@gnu.org>
Date: Sat, 2 Jul 2016 03:05:33 +0200
Subject: Add (cuirass utils) module.

Move 'with-directory-excursion' here.
---
 Makefile.am           |  3 ++-
 bin/cuirass.in        |  1 +
 src/cuirass/base.scm  | 17 ++------------
 src/cuirass/utils.scm | 65 +++++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 70 insertions(+), 16 deletions(-)
 create mode 100644 src/cuirass/utils.scm

diff --git a/Makefile.am b/Makefile.am
index 1ecb01c..d2d4821 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -7,7 +7,8 @@ dist_pkgmodule_DATA = \
   src/cuirass/base.scm \
   src/cuirass/database.scm \
   src/cuirass/job.scm \
-  src/cuirass/ui.scm
+  src/cuirass/ui.scm \
+  src/cuirass/utils.scm
 
 nodist_pkgmodule_DATA = \
   $(dist_pkgmodule_DATA:%.scm=%.go) \
diff --git a/bin/cuirass.in b/bin/cuirass.in
index 23ac649..ae201d1 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -26,6 +26,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
              (cuirass database)
              (cuirass job)
              (cuirass ui)
+             (cuirass utils)
              (ice-9 getopt-long))
 
 (define* (show-help)
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)))))
-- 
cgit v1.2.3