From 7da95264f196d1c5dfa01654e87a319bce458cc1 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 17 Oct 2012 22:51:08 +0200
Subject: utils: Add `mkdir-p'; use it.

* guix/build/utils.scm (mkdir-p): New procedure.

* distro/packages/base.scm (gnu-make-boot0, gcc-boot0-wrapped,
  ld-wrapper-boot3, %static-binaries, %guile-static-stripped): Use it.
* distro/packages/typesetting.scm (lout): Likewise.
---
 distro/packages/base.scm        | 19 ++++++-------------
 distro/packages/typesetting.scm |  6 ++----
 guix/build/utils.scm            | 26 ++++++++++++++++++++++++++
 3 files changed, 34 insertions(+), 17 deletions(-)

diff --git a/distro/packages/base.scm b/distro/packages/base.scm
index 3a22b65f13..7fb26881e2 100644
--- a/distro/packages/base.scm
+++ b/distro/packages/base.scm
@@ -1481,8 +1481,7 @@ (define gnu-make-boot0
                    'install (lambda* (#:key outputs #:allow-other-keys)
                               (let* ((out (assoc-ref outputs "out"))
                                      (bin (string-append out "/bin")))
-                                (mkdir out)
-                                (mkdir bin)
+                                (mkdir-p bin)
                                 (copy-file "make"
                                            (string-append bin "/make"))))
                    %standard-phases))))
@@ -1709,7 +1708,7 @@ (define gcc-boot0-wrapped
                            (out      (assoc-ref %outputs "out"))
                            (bindir   (string-append out "/bin"))
                            (triplet  ,(boot-triplet system)))
-                      (mkdir out) (mkdir bindir)
+                      (mkdir-p bindir)
                       (with-directory-excursion bindir
                         (for-each (lambda (tool)
                                     (symlink (string-append binutils "/bin/"
@@ -1807,7 +1806,7 @@ (define ld-wrapper-boot3
                              (assoc-ref %build-inputs "binutils")
                              out)
 
-                     (mkdir out) (mkdir bin)
+                     (mkdir-p bin)
                      (copy-file (assoc-ref %build-inputs "wrapper") ld)
                      (substitute* ld
                        (("@GUILE@")
@@ -2020,7 +2019,7 @@ (define (copy-directory source destination)
 
           (let* ((out (assoc-ref %outputs "out"))
                  (bin (string-append out "/bin")))
-            (mkdir out) (mkdir bin)
+            (mkdir-p bin)
 
             ;; Copy Coreutils binaries.
             (let* ((coreutils (assoc-ref %build-inputs "coreutils"))
@@ -2127,17 +2126,11 @@ (define (copy-recursively source destination)
 
          (let ((in  (assoc-ref %build-inputs "guile"))
                (out (assoc-ref %outputs "out")))
-           (mkdir out)
-           (mkdir (string-append out "/share"))
-           (mkdir (string-append out "/share/guile"))
-           (mkdir (string-append out "/share/guile/2.0"))
+           (mkdir-p (string-append out "/share/guile/2.0"))
            (copy-recursively (string-append in "/share/guile/2.0")
                              (string-append out "/share/guile/2.0"))
 
-           (mkdir (string-append out "/lib"))
-           (mkdir (string-append out "/lib/guile"))
-           (mkdir (string-append out "/lib/guile/2.0"))
-           (mkdir (string-append out "/lib/guile/2.0/ccache"))
+           (mkdir-p (string-append out "/lib/guile/2.0/ccache"))
            (copy-recursively (string-append in "/lib/guile/2.0/ccache")
                              (string-append out "/lib/guile/2.0/ccache"))
 
diff --git a/distro/packages/typesetting.scm b/distro/packages/typesetting.scm
index cd0eae1187..5ca33c628a 100644
--- a/distro/packages/typesetting.scm
+++ b/distro/packages/typesetting.scm
@@ -46,12 +46,10 @@ (define-public lout
                 (("^MANDIR[[:blank:]]*=.*$")
                  (string-append "MANDIR = " out "/man\n")))
               (mkdir out)
-              (mkdir (string-append out "/bin"))  ; TODO: use `mkdir-p'
+              (mkdir (string-append out "/bin"))
               (mkdir (string-append out "/lib"))
               (mkdir (string-append out "/man"))
-              (mkdir doc)
-              (mkdir (string-append doc "/doc"))
-              (mkdir (string-append doc "/doc/lout")))))
+              (mkdir-p (string-append doc "/doc/lout")))))
         (install-man-phase
          '(lambda* (#:key outputs #:allow-other-keys)
             (zero? (system* "make" "installman"))))
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index d1d3116c45..0543ab48d5 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -26,6 +26,7 @@ (define-module (guix build utils)
   #:use-module (rnrs io ports)
   #:export (directory-exists?
             with-directory-excursion
+            mkdir-p
             set-path-environment-variable
             search-path-as-string->list
             list->search-path-as-string
@@ -62,6 +63,31 @@ (define-syntax-rule (with-directory-excursion dir body ...)
      (lambda ()
        (chdir init)))))
 
+(define (mkdir-p dir)
+  "Create directory DIR and all its ancestors."
+  (define absolute?
+    (string-prefix? "/" dir))
+
+  (define not-slash
+    (char-set-complement (char-set #\/)))
+
+  (let loop ((components (string-tokenize dir not-slash))
+             (root       (if absolute?
+                             ""
+                             ".")))
+    (match components
+      ((head tail ...)
+       (let ((path (string-append root "/" head)))
+         (catch 'system-error
+           (lambda ()
+             (mkdir path)
+             (loop tail path))
+           (lambda args
+             (if (= EEXIST (system-error-errno args))
+                 (loop tail path)
+                 (apply throw args))))))
+      (() #t))))
+
 
 ;;;
 ;;; Search paths.
-- 
cgit v1.2.3