From c15b9fff1bcd90848c6c16a9e2e5cfa30337ace7 Mon Sep 17 00:00:00 2001
From: divoplade <d@divoplade.fr>
Date: Fri, 23 Oct 2020 22:44:36 +0200
Subject: [PATCH 1/2] ports: Add mkdir-recursive

2020-10-25 divoplade <d@divoplade.fr>
	* module/ice-9/ports.scm: add a function, mkdir-recursive, to
	create the chain of directories.
	* doc/ref/posix.texi: document the new function mkdir-recursive.
	* NEWS: mention the new function.
	* test-suite/tests/ports.test: add a test suite to check
	recursive mkdir.
---
 NEWS                        |  5 +++++
 doc/ref/posix.texi          | 15 ++++++++++----
 module/ice-9/ports.scm      | 16 +++++++++++++++
 test-suite/tests/ports.test | 40 +++++++++++++++++++++++++++++++++++++
 4 files changed, 72 insertions(+), 4 deletions(-)

diff --git a/NEWS b/NEWS
index 694449202..94a3f3154 100644
--- a/NEWS
+++ b/NEWS
@@ -16,6 +16,11 @@ O(1) dispatch time, regardless of the length of the chain.  This
 optimization is also unlocked in many cases for `match' expressions with
 many similar clauses whose first differentiator are constants.
 
+** New function mkdir-recursive
+
+This function will try and create the directory and parent directories,
+up to a directory that can be opened or the root.
+
 * Incompatible changes
 
 ** `copy' read-option removed
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index f34c5222d..cb9943977 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -881,10 +881,17 @@ Create a symbolic link named @var{newpath} with the value (i.e., pointing to)
 @deffn {Scheme Procedure} mkdir path [mode]
 @deffnx {C Function} scm_mkdir (path, mode)
 Create a new directory named by @var{path}.  If @var{mode} is omitted
-then the permissions of the directory are set to @code{#o777}
-masked with the current umask (@pxref{Processes, @code{umask}}).
-Otherwise they are set to the value specified with @var{mode}.
-The return value is unspecified.
+then the permissions of the directory are set to @code{#o777} masked
+with the current umask (@pxref{Processes, @code{umask}}).  Otherwise
+they are set to the value specified with @var{mode}.  The return value
+is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} mkdir-recursive @var{path} [mode]
+Create the directory named @var{path}, with the optional given
+@var{mode}, as for @code{mkdir}. Create all parent directories up to a
+directory that can be opened, or the root. The chain of directories is
+not cleaned in case of an error.
 @end deffn
 
 @deffn {Scheme Procedure} rmdir path
diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm
index dbc7ef7a7..ed074238b 100644
--- a/module/ice-9/ports.scm
+++ b/module/ice-9/ports.scm
@@ -105,6 +105,7 @@
             OPEN_READ OPEN_WRITE OPEN_BOTH
             *null-device*
             open-input-file
+            mkdir-recursive
             open-output-file
             open-io-file
             call-with-input-file
@@ -413,6 +414,21 @@ cannot be opened, an error is signalled."
              #:encoding encoding
              #:guess-encoding guess-encoding))
 
+(define (mkdir-recursive name)
+  "Create the parent directories of @var{name}, up to an existing
+directory, or up to the root."
+  (catch 'system-error
+    (lambda ()
+      (mkdir name))
+    (lambda error
+      (unless (= EEXIST (system-error-errno error))
+        (mkdir-recursive (dirname name))
+        (catch 'system-error
+          (lambda ()
+            (mkdir name))
+          (lambda error
+            #t))))))
+
 (define* (open-output-file file #:key (binary #f) (encoding #f))
   "Takes a string naming an output file to be created and returns an
 output port capable of writing characters to a new file by that
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 31fb2b0a8..ab696195b 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -2022,6 +2022,46 @@
 
 (delete-file (test-file))
 
+(with-test-prefix "recursive mkdir"
+
+  (pass-if "Relative recursive mkdir creates the chain of directories"
+    (let ((dir "./nested/relative/subdirectory"))
+      (mkdir-recursive dir)
+      (let ((ok
+             (catch #t
+               (lambda ()
+                 (with-output-to-file "./nested/relative/subdirectory/file"
+                   (lambda ()
+                     (display "The directories have been created!")
+                     #t)))
+               (lambda (error . args)
+                 #f))))
+        (when ok
+          (delete-file "./nested/relative/subdirectory/file")
+          (rmdir "./nested/relative/subdirectory")
+          (rmdir "./nested/relative")
+          (rmdir "./nested"))
+        ok)))
+
+  (pass-if "Absolute recursive mkdir creates the chain of directories"
+    (let ((dir (string-append %temporary-directory "/nested/absolute/subdirectory")))
+      (mkdir-recursive dir)
+      (let ((ok
+             (catch #t
+               (lambda ()
+                 (with-output-to-file (string-append dir "/file")
+                   (lambda ()
+                     (display "The directories have been created!")
+                     #t)))
+               (lambda (error . args)
+                 #f))))
+        (when ok
+          (delete-file (string-append dir "/file"))
+          (rmdir (string-append %temporary-directory "/nested/absolute/subdirectory"))
+          (rmdir (string-append %temporary-directory "/nested/absolute"))
+          (rmdir (string-append %temporary-directory "/nested")))
+        ok))))
+
 ;;; Local Variables:
 ;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
 ;;; eval: (put 'with-load-path 'scheme-indent-function 1)
-- 
2.29.1