I also added a keyword argument to the output functions so that they
can create the directory of the file if needed. What do you think?
From 0e6c74700d2eeb2142ff17ecdb0973806cf79b68 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-23 divoplade <d...@divoplade.fr>
* module/ice-9/ports.scm (open-output-file): add a recursive
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 | 28 ++++++++++++++++++----------
3 files changed, 35 insertions(+), 15 deletions(-)
diff --git a/NEWS b/NEWS
index 765f3d2a3..f302f5fdc 100644
--- a/NEWS
+++ b/NEWS
@@ -19,7 +19,11 @@ many similar clauses whose first differentiator are constants.
** Additional optional argument in `mkdir' to create the directory recursively
When the third argument to mkdir is true, the intermediate directories
-are created.
+are created. 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
+#:recursive 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..7409e6699 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] [#:recursive=#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 recursive
+ (mkdir (dirname @var{filename}) #o777 #t))
(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] [#:recursive=#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{recursive} 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] [#:recursive=#f]
@deffnx {Scheme Procedure} with-error-to-file filename thunk @
- [#:encoding=#f] [#:binary=#f]
+ [#:encoding=#f] [#:binary=#f] [#:recursive=#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{recursive} 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..08ba0cff9 100644
--- a/module/ice-9/ports.scm
+++ b/module/ice-9/ports.scm
@@ -413,11 +413,15 @@ 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) (recursive #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."
+file with the given name already exists, the effect is unspecified.
+If @var{recursive} is true, recursively create the directory of
+@var{file}."
+ (when recursive
+ (mkdir (dirname file) #o777 #t))
(open-file file (if binary "wb" "w")
#:encoding encoding))
@@ -447,7 +451,7 @@ 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) (recursive #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
@@ -457,8 +461,9 @@ 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)))
+never again be used for a read or write operation. When RECURSIVE is
+true, create FILE's directory and all its parents."
+ (let ((p (open-output-file file #:binary binary #:encoding encoding #:recursive recursive)))
(call-with-values
(lambda () (proc p))
(lambda vals
@@ -494,7 +499,7 @@ procedures, their behavior is implementation dependent."
#:encoding encoding
#:guess-encoding guess-encoding))
-(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
+(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f) (recursive #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
@@ -503,13 +508,15 @@ 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."
+procedures, their behavior is implementation dependent. When RECURSIVE
+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
+ #:recursive recursive))
-(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
+(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f) (recursive #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
@@ -522,7 +529,8 @@ procedures, their behavior is implementation dependent."
(call-with-output-file file
(lambda (p) (with-error-to-port p thunk))
#:binary binary
- #:encoding encoding))
+ #:encoding encoding
+ #:recursive recursive))
(define (call-with-input-string string proc)
"Calls the one-argument procedure @var{proc} with a newly created
--
2.28.0
From 6b6920e05b2afefc3729bd60760c26d2476f5c82 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] mkdir: Add an optional argument, recursive, to create the
intermediates
2020-10-23 divoplade <d...@divoplade.fr>
* libguile/filesys.c: include eq.h, so we can compare strings.
* libguile/filesys.c (scm_mkdir): add an optional argument,
recursive, to create the intermediate directories if they do not
exist.
* libguile/filesys.h (scm_mkdir): add the optional argument to
the prototype.
* doc/ref/posix.texi (mkdir): document the new optional
argument.
* NEWS: say there is a new argument.
* test-suite/tests/ports.test: add a test suite to check
recursive mkdir.
---
NEWS | 5 +++++
doc/ref/posix.texi | 7 +++++--
libguile/filesys.c | 39 ++++++++++++++++++++++++++++++++++--
libguile/filesys.h | 2 +-
test-suite/tests/ports.test | 40 +++++++++++++++++++++++++++++++++++++
5 files changed, 88 insertions(+), 5 deletions(-)
diff --git a/NEWS b/NEWS
index 694449202..765f3d2a3 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.
+** Additional optional argument in `mkdir' to create the directory recursively
+
+When the third argument to mkdir is true, the intermediate directories
+are created.
+
* Incompatible changes
** `copy' read-option removed
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index f34c5222d..db0cdeae0 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -878,12 +878,15 @@ Create a symbolic link named @var{newpath} with the value (i.e., pointing to)
@var{oldpath}. The return value is unspecified.
@end deffn
-@deffn {Scheme Procedure} mkdir path [mode]
-@deffnx {C Function} scm_mkdir (path, mode)
+@deffn {Scheme Procedure} mkdir path [mode [recursive]]
+@deffnx {C Function} scm_mkdir (path, mode, recursive)
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}.
+If @var{recursive} is true, also try to create the intermediate missing
+directories. If an error happens, the created directories are left in
+place.
The return value is unspecified.
@end deffn
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 39bfd38cc..a3c26cfe0 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -82,6 +82,7 @@
#include "async.h"
#include "boolean.h"
#include "dynwind.h"
+#include "eq.h"
#include "fdes-finalizers.h"
#include "feature.h"
#include "fports.h"
@@ -1271,12 +1272,15 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_GETCWD */
-SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
- (SCM path, SCM mode),
+SCM_DEFINE (scm_mkdir, "mkdir", 1, 2, 0,
+ (SCM path, SCM mode, SCM recursive),
"Create a new directory named by @var{path}. If @var{mode} is omitted\n"
"then the permissions of the directory are set to @code{#o777}\n"
"masked with the current umask (@pxref{Processes, @code{umask}}).\n"
"Otherwise they are set to the value specified with @var{mode}.\n"
+ "If @var{recursive} is true, also try tocreate the intermediate missing\n"
+ "directories. If an error happens, the created directories are left\n"
+ "in place.\n"
"The return value is unspecified.")
#define FUNC_NAME s_scm_mkdir
{
@@ -1285,6 +1289,37 @@ SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
c_mode = SCM_UNBNDP (mode) ? 0777 : scm_to_uint (mode);
+ if (scm_is_true (recursive))
+ {
+ /* Record in paths all intermediate directory names up to the
+ root. The root is reached when the dirname of the current
+ directory is equal to the directory. */
+ SCM paths = SCM_EOL;
+ SCM current_name = path;
+ SCM parent_name = scm_dirname (current_name);
+ while (!scm_is_true (scm_equal_p (parent_name, current_name)))
+ {
+ paths = scm_cons (parent_name, paths);
+ current_name = parent_name;
+ parent_name = scm_dirname (current_name);
+ }
+ if (scm_is_true (scm_equal_p (current_name, scm_from_utf8_string ("."))))
+ {
+ /* If the root is '.', then also make the current working
+ directory the same way. */
+ scm_mkdir (scm_getcwd (), mode, recursive);
+ }
+ while (!scm_is_null (paths))
+ {
+ SCM dir = scm_car (paths);
+ /* Ignore the errors. If one mkdir fails, the final
+ STRING_SYSCALL at the end of this function will fail
+ too. */
+ STRING_SYSCALL (dir, c_dir, mkdir (c_dir, c_mode));
+ paths = scm_cdr (paths);
+ }
+ }
+
STRING_SYSCALL (path, c_path, rv = mkdir (c_path, c_mode));
if (rv != 0)
SCM_SYSERROR;
diff --git a/libguile/filesys.h b/libguile/filesys.h
index f870ee434..011cc5d1d 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -49,7 +49,7 @@ SCM_API SCM scm_stat (SCM object, SCM exception_on_error);
SCM_API SCM scm_link (SCM oldpath, SCM newpath);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
SCM_API SCM scm_delete_file (SCM str);
-SCM_API SCM scm_mkdir (SCM path, SCM mode);
+SCM_API SCM scm_mkdir (SCM path, SCM mode, SCM recursive);
SCM_API SCM scm_rmdir (SCM path);
SCM_API SCM scm_directory_stream_p (SCM obj);
SCM_API SCM scm_opendir (SCM dirname);
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 31fb2b0a8..4a247240e 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 dir #o777 #t)
+ (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 dir #o777 #t)
+ (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
