bug#44186: Recursive mkdir

[divoplade <d@divoplade.fr>]

[-- Attachment #1: Type: text/plain, Size: 1000 bytes --]

Le mardi 27 octobre 2020 à 10:19 +0100, Leo Prikler a écrit :
> Returning #t on error won't actually
> fix them.
Do you mean that ignoring errors on mkdir when there has been a called
to mkdir-recursive just before is not OK? I agree, it's better if
mkdir-recursive fails if one element of the chain can't be created,
even if the parent exists or has been created. I updated the function.

> That would allow you
> to put mkdir-recursive into the posix module (and test it along with
> it) even if it isn't strictly POSIX.

So, that's what I did; the code is now in the posix module.

> > How do you run the tests? When I run "make check", I get 1 of 39
> > tests failed, the test-out-of-memory test. It does not even try to
> > run the ports test.
> Have a look at test-suite/Makefile.am.

(Now the relevant test is posix.test, not ports.test anymore)

I found it: I just needed to run the ./check-guile script. Now, both
recusive mkdir tests in posix.test run smoothly.

Best regards,

divoplade

[-- Attachment #2: 0002-Use-the-recursive-mkdir-function-in-file-output-proc.patch --]
[-- Type: text/x-patch, Size: 11805 bytes --]

From 3c43cd66b8d0d1ada76b19f0b073b7fee0c107c7 Mon Sep 17 00:00:00 2001
From: divoplade <d@divoplade.fr>
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 <d@divoplade.fr>
	* 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    | 38 ++++++++++++++-------
 module/ice-9/ports.scm | 75 ++++++++++++++++++++++--------------------
 3 files changed, 71 insertions(+), 48 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..0c6beec20 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -1036,13 +1036,16 @@ 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
+character encoding as described above for @code{open-file}.  If
+@var{mkdir} is true, recursively create the directory of @var{filename}
+if it does not exist first.  Equivalent to
 @lisp
+(when @var{mkdir}
+  (mkdir-recursive (dirname @var{filename})))
 (open-file @var{filename}
            (if @var{binary} "wb" "w")
            #:encoding @var{encoding})
@@ -1052,12 +1055,14 @@ 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}
-port)} with the resulting port.  Return the value returned by
-@var{proc}.  @var{filename} is opened as per @code{open-input-file} or
+port)} with the resulting port.  For @var{call-with-output-file}, if
+@var{mkdir} is true, create the directory of @var{filename} recursively
+if it does not exist first.  Return the value returned by @var{proc}.
+@var{filename} is opened as per @code{open-input-file} or
 @code{open-output-file} respectively, and an error is signaled if it
 cannot be opened.
 
@@ -1065,22 +1070,28 @@ 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
 setup as respectively the @code{current-input-port},
-@code{current-output-port}, or @code{current-error-port}.  Return the
-value returned by @var{thunk}.  @var{filename} is opened as per
-@code{open-input-file} or @code{open-output-file} respectively, and an
-error is signaled if it cannot be opened.
+@code{current-output-port}, or @code{current-error-port}.  For
+@var{with-output-to-file} and @var{with-error-to-file}, if @var{mkdir}
+is true, recursively create the directory of @var{filename} if it does
+not exist first.  Return the value returned by @var{thunk}.
+@var{filename} is opened as per @code{open-input-file} or
+@code{open-output-file} respectively, and an error is signaled if it
+cannot be opened.
 
 When @var{thunk} returns, the port is closed and the previous setting
 of the respective current port is restored.
@@ -1095,6 +1106,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 dbc7ef7a7..463479f2b 100644
--- a/module/ice-9/ports.scm
+++ b/module/ice-9/ports.scm
@@ -413,11 +413,14 @@ cannot be opened, an error is signalled."
              #:encoding encoding
              #:guess-encoding guess-encoding))
 
-(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-recursive (dirname file)))
   (open-file file (if binary "wb" "w")
              #:encoding encoding))
 
@@ -447,18 +450,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
@@ -494,35 +497,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.29.1


[-- Attachment #3: 0001-ports-Add-mkdir-recursive.patch --]
[-- Type: text/x-patch, Size: 5237 bytes --]

From c87973b9b11eeb90c9d08d00b3e7c13facd60d82 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/posix.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/posix.test: add a test suite to check
	recursive mkdir.
---
 NEWS                        |  5 ++++
 doc/ref/posix.texi          | 15 ++++++++----
 module/ice-9/posix.scm      | 11 +++++++++
 test-suite/tests/posix.test | 47 +++++++++++++++++++++++++++++++++++++
 4 files changed, 74 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/posix.scm b/module/ice-9/posix.scm
index b00267665..c43ed5a27 100644
--- a/module/ice-9/posix.scm
+++ b/module/ice-9/posix.scm
@@ -73,3 +73,14 @@
 
 (define (getgrnam name) (getgr name))
 (define (getgrgid id) (getgr id))
+
+(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))
+        (mkdir name)))))
diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test
index aa0dbc1b2..063bf205b 100644
--- a/test-suite/tests/posix.test
+++ b/test-suite/tests/posix.test
@@ -276,3 +276,50 @@
                ;; or not is system-defined, so it's possible it just works.
                (string? (crypt "pass" "$X$abc")))
              (lambda _ #t)))))
+
+;;
+;; recursive mkdir
+;;
+
+(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* ((%temporary-directory
+            (string-append (or (getenv "TMPDIR") "/tmp") "/guile-posix-test."
+                           (number->string (getpid))))
+           (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))))
-- 
2.29.1