Hello!
Le dimanche 25 octobre 2020 à 08:45 +0100, Ricardo Wurmus a écrit :
> > > To be clear, you would rather have that function as guile code
> > > rather
> > > than extending the C function? I'm OK with that, but in which
> > > file
> > > should I put that function? My instinct was to put the code near
> > > the
> > > mkdir function, and that happened to be in a C file, so I went C.
>
> We should all be writing fewer lines of C code and more Scheme :)
OK, but where do I put the function? There is a posix.scm, but this
function is not posix, and posix.scm does not seem to export functions.
By default I will put it in ports.scm, because it is useful for open-
output-directory.
Also, I still cannot run the ports tests! How do I do it? Also test-
out-of-memory fails, but it also fails on master.
Attached, the new version for you to read!
Best regards,
divoplade
From 29c98e8371a32b11c0c13f8fa91628aeedc117bf 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 | 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 <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 | 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
