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
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
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