bug#44186: Recursive mkdir

From 29c98e8371a32b11c0c13f8fa91628aeedc117bf Mon Sep 17 00:00:00 2001
From: divoplade <[email protected]>
Date: Sat, 24 Oct 2020 00:35:01 +0200
Subject: [PATCH 2/2] Use the recursive mkdir function in file output
 procedures

2020-10-25 divoplade <[email protected]>
	* module/ice-9/ports.scm (open-output-file): add a mkdir keyword
	to try to recursively create the directory of the output file.
	* module/ice-9/ports.scm (call-with-output-file): same.
	* module/ice-9/ports.scm (with-output-to-file): same.
	* module/ice-9/ports.scm (with-error-to-file): same.
	* doc/ref/api-io.texi: document the new keyword argument for
	opening output files.
	* NEWS: indicate that the open output function can now create
	the filename directory if it does not exist.
---
 NEWS                   |  6 +++-
 doc/ref/api-io.texi    | 16 ++++++---
 module/ice-9/ports.scm | 75 ++++++++++++++++++++++--------------------
 3 files changed, 57 insertions(+), 40 deletions(-)

diff --git a/NEWS b/NEWS
index 94a3f3154..09e06a7ba 100644
--- a/NEWS
+++ b/NEWS
@@ -19,7 +19,11 @@ 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.
+up to a directory that can be opened or the root. This behavior is
+included in open-output-file, call-with-output-file, with-output-to-file
+and with-error-to-file by adding a keyword argument `#:mkdir' which,
+when set to `#t', creates the directories before trying to open the
+file.
 
 * Incompatible changes
 
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index ecbd35585..dabceb646 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -1036,13 +1036,15 @@ for @code{open-file}.  Equivalent to
 
 @rnindex open-output-file
 @deffn {Scheme Procedure} open-output-file filename @
-       [#:encoding=#f] [#:binary=#f]
+       [#:encoding=#f] [#:binary=#f] [#:mkdir=#f]
 
 Open @var{filename} for output.  If @var{binary} is true, open the port
 in binary mode, otherwise use text mode.  @var{encoding} specifies the
 character encoding as described above for @code{open-file}.  Equivalent
 to
 @lisp
+(when @var{mkdir}
+  (mkdir-recursive (dirname @var{filename})))
 (open-file @var{filename}
            (if @var{binary} "wb" "w")
            #:encoding @var{encoding})
@@ -1052,7 +1054,7 @@ to
 @deffn {Scheme Procedure} call-with-input-file filename proc @
         [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f]
 @deffnx {Scheme Procedure} call-with-output-file filename proc @
-        [#:encoding=#f] [#:binary=#f]
+        [#:encoding=#f] [#:binary=#f] [#:mkdir=#f]
 @rnindex call-with-input-file
 @rnindex call-with-output-file
 Open @var{filename} for input or output, and call @code{(@var{proc}
@@ -1065,14 +1067,17 @@ When @var{proc} returns, the port is closed.  If @var{proc} does not
 return (e.g.@: if it throws an error), then the port might not be
 closed automatically, though it will be garbage collected in the usual
 way if not otherwise referenced.
+
+If @var{mkdir} is true, create @var{filename}'s directory and all
+its parents.
 @end deffn
 
 @deffn {Scheme Procedure} with-input-from-file filename thunk @
         [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f]
 @deffnx {Scheme Procedure} with-output-to-file filename thunk @
-        [#:encoding=#f] [#:binary=#f]
+        [#:encoding=#f] [#:binary=#f] [#:mkdir=#f]
 @deffnx {Scheme Procedure} with-error-to-file filename thunk @
-        [#:encoding=#f] [#:binary=#f]
+        [#:encoding=#f] [#:binary=#f] [#:mkdir=#f]
 @rnindex with-input-from-file
 @rnindex with-output-to-file
 Open @var{filename} and call @code{(@var{thunk})} with the new port
@@ -1095,6 +1100,9 @@ exited via an exception or new continuation.  This ensures it's still
 ready for use if @var{thunk} is re-entered by a captured continuation.
 Of course the port is always garbage collected and closed in the usual
 way when no longer referenced anywhere.
+
+If @var{mkdir} is true, then @var{filename}'s directory and all its
+parents are created.
 @end deffn
 
 @deffn {Scheme Procedure} port-mode port
diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm
index 3ed289e43..579c503f6 100644
--- a/module/ice-9/ports.scm
+++ b/module/ice-9/ports.scm
@@ -446,11 +446,14 @@ opened) and that will need to be created."
       (make-dirs (cdr dirs))))
   (make-dirs (trace-dirs '() name)))
 
-(define* (open-output-file file #:key (binary #f) (encoding #f))
+(define* (open-output-file file #:key (binary #f) (encoding #f) (mkdir #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
-name.  If the file cannot be opened, an error is signalled.  If a
-file with the given name already exists, the effect is unspecified."
+output port capable of writing characters to a new file by that name.
+If the file cannot be opened, an error is signalled.  If a file with the
+given name already exists, the effect is unspecified.  If @var{mkdir} is
+true, recursively create the directory of @var{file}."
+  (when mkdir
+    (mkdir-p (dirname file)))
   (open-file file (if binary "wb" "w")
              #:encoding encoding))
 
@@ -480,18 +483,18 @@ never again be used for a read or write operation."
         (close-input-port p)
         (apply values vals)))))
 
-(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
+(define* (call-with-output-file file proc #:key (binary #f) (encoding #f) (mkdir #f))
   "PROC should be a procedure of one argument, and FILE should be a
-string naming a file.  The behaviour is unspecified if the file
-already exists. These procedures call PROC
-with one argument: the port obtained by opening the named file for
-input or output.  If the file cannot be opened, an error is
-signalled.  If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned.
-If the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will
-never again be used for a read or write operation."
-  (let ((p (open-output-file file #:binary binary #:encoding encoding)))
+string naming a file.  The behaviour is unspecified if the file already
+exists. These procedures call PROC with one argument: the port obtained
+by opening the named file for input or output.  If the file cannot be
+opened, an error is signalled.  If the procedure returns, then the port
+is closed automatically and the values yielded by the procedure are
+returned.  If the procedure does not return, then the port will not be
+closed automatically unless it is possible to prove that the port will
+never again be used for a read or write operation. When MKDIR is true,
+create FILE's directory and all its parents."
+  (let ((p (open-output-file file #:binary binary #:encoding encoding #:mkdir mkdir)))
     (call-with-values
       (lambda () (proc p))
       (lambda vals
@@ -527,35 +530,37 @@ procedures, their behavior is implementation dependent."
    #:encoding encoding
    #:guess-encoding guess-encoding))
 
-(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
-  "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file.  The effect is unspecified if the file already exists.
+(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f) (mkdir #f))
+  "THUNK must be a procedure of no arguments, and FILE must be a string
+naming a file.  The effect is unspecified if the file already exists.
 The file is opened for output, an output port connected to it is made
-the default value returned by `current-output-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored.  Returns the values yielded by THUNK.  If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
+the default value returned by `current-output-port', and the THUNK is
+called with no arguments.  When the THUNK returns, the port is closed
+and the previous default is restored.  Returns the values yielded by
+THUNK.  If an escape procedure is used to escape from the continuation
+of these procedures, their behavior is implementation dependent. When
+MKDIR is true, the directory of FILE and all its parents are created."
   (call-with-output-file file
    (lambda (p) (with-output-to-port p thunk))
    #:binary binary
-   #:encoding encoding))
+   #:encoding encoding
+   #:mkdir mkdir))
 
-(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
-  "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file.  The effect is unspecified if the file already exists.
+(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f) (mkdir #f))
+  "THUNK must be a procedure of no arguments, and FILE must be a string
+naming a file.  The effect is unspecified if the file already exists.
 The file is opened for output, an output port connected to it is made
-the default value returned by `current-error-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored.  Returns the values yielded by THUNK.  If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
+the default value returned by `current-error-port', and the THUNK is
+called with no arguments.  When the THUNK returns, the port is closed
+and the previous default is restored.  Returns the values yielded by
+THUNK.  If an escape procedure is used to escape from the continuation
+of these procedures, their behavior is implementation dependent. When
+MKDIR is true, the directory of FILE and all its parents are created."
   (call-with-output-file file
    (lambda (p) (with-error-to-port p thunk))
    #:binary binary
-   #:encoding encoding))
+   #:encoding encoding
+   #:mkdir mkdir))
 
 (define (call-with-input-string string proc)
   "Calls the one-argument procedure @var{proc} with a newly created
-- 
2.28.0

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

2020-10-25 divoplade <[email protected]>
	* 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      | 33 ++++++++++++++++++++++++++++++
 test-suite/tests/ports.test | 40 +++++++++++++++++++++++++++++++++++++
 4 files changed, 89 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..3ed289e43 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,38 @@ 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 a directory that
+can be opened, or up to the root."
+  (define (trace-dirs job name)
+    "Record all the directories that do not exist (i.e. that cannot be
+opened) and that will need to be created."
+    (catch 'system-error
+      (lambda ()
+        (closedir (opendir name))
+        job)
+      (lambda (error . args)
+        (let ((dir (dirname name)))
+          (if (string=? dir name)
+              ;; This is either the root of the file system, or the
+              ;; current working directory. If the current directory
+              ;; does not exist, calling (getcwd) is an error, so we
+              ;; cannot know where it is in order to create
+              ;; it. Otherwise we would call (trace-dirs job
+              ;; (getcwd)). So now we assume that dir and name is the
+              ;; root, and they do not need to be created.
+              job
+              (trace-dirs (cons name job) dir))))))
+  (define (make-dirs dirs)
+    (unless (null? dirs)
+      (catch 'system-error
+        (lambda ()
+          (mkdir (car dirs)))
+        (lambda (error . args)
+          #t))
+      (make-dirs (cdr dirs))))
+  (make-dirs (trace-dirs '() name)))
+
 (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.28.0