bug#44186: Recursive mkdir

From d69f24617290c4a875ff2356ca229bf1659feafe Mon Sep 17 00:00:00 2001
From: divoplade <[email protected]>
Date: Fri, 23 Oct 2020 22:44:36 +0200
Subject: [PATCH] mkdir: Add an optional argument, recursive, to create the
 intermediates

2020-10-23 divoplade <[email protected]>
	* 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..c2b8b0596 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -2020,6 +2020,46 @@
           (not (string-index (%search-load-path (basename (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 dir #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 dir #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))))
+
 (delete-file (test-file))
 
 ;;; Local Variables:
-- 
2.28.0