From 7da95264f196d1c5dfa01654e87a319bce458cc1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 17 Oct 2012 22:51:08 +0200
Subject: [PATCH] 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 3a22b65f13e..7fb26881e24 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 cd0eae1187b..5ca33c628a4 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 d1d3116c459..0543ab48d5a 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.
--
GitLab