From d72267863382041b84a9712eea354882be72ef55 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Oct 2016 21:36:58 +0200 Subject: grafts: Always make directories #o755. Fixes . Reported by Albin and Jeffrey Serio . * guix/build/graft.scm (mkdir-p*): New procedure. (rewrite-directory): Use it instead of 'mkdir-p'. --- guix/build/graft.scm | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) (limited to 'guix/build/graft.scm') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index b08b65b7cf..7025b72fea 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -210,6 +210,32 @@ an exception is caught." (print-exception port #f key args) (primitive-exit 1)))))) +(define* (mkdir-p* dir #:optional (mode #o755)) + "This is a variant of 'mkdir-p' that works around + by passing MODE explicitly in each 'mkdir' call." + (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 mode) + (loop tail path)) + (lambda args + (if (= EEXIST (system-error-errno args)) + (loop tail path) + (apply throw args)))))) + (() #t)))) + (define* (rewrite-directory directory output mapping #:optional (store (%store-directory))) "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of @@ -258,7 +284,7 @@ file name pairs." (define (rewrite-leaf file) (let ((stat (lstat file)) (dest (destination file))) - (mkdir-p (dirname dest)) + (mkdir-p* (dirname dest)) (case (stat:type stat) ((symlink) (let ((target (readlink file))) @@ -277,7 +303,7 @@ file name pairs." store) (chmod output (stat:perms stat))))))) ((directory) - (mkdir-p dest)) + (mkdir-p* dest)) (else (error "unsupported file type" stat))))) -- cgit v1.2.3