[Guile-commits] 05/14: Define bindings to ‘mkdirat’ when the C function exists.

[Ludovic Courtès]

civodul pushed a commit to branch main
in repository guile.

commit 58ddd5c7bc3907c1f1e4dd9637d996c4d72eaba0
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Tue Nov 16 11:06:28 2021 +0000

    Define bindings to ‘mkdirat’ when the C function exists.
    
    * configure.ac: Detect if ‘mkdirat’ exists.
    * libguile/filesys.c (scm_mkdirat): Define the Scheme binding.
    * doc/ref/posix.texi (File System): Document it.
    
    Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
 configure.ac                  |  2 +-
 doc/ref/posix.texi            |  6 ++++++
 libguile/filesys.c            | 25 +++++++++++++++++++++++++
 libguile/filesys.h            |  1 +
 test-suite/tests/filesys.test | 38 ++++++++++++++++++++++++++++++++++++++
 5 files changed, 71 insertions(+), 1 deletion(-)

diff --git a/configure.ac b/configure.ac
index 49e30d20b..9f9d5c71b 100644
--- a/configure.ac
+++ b/configure.ac
@@ -517,7 +517,7 @@ AC_CHECK_HEADERS([crt_externs.h])
 #
 AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid         \
   fesetround ftime ftruncate fchown fchmod fchdir readlinkat           \
-  symlinkat getcwd geteuid getsid                                              
        \
+  symlinkat mkdirat getcwd geteuid getsid                              \
   gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod   \
   nice readlink rmdir setegid seteuid                            \
   setuid setgid setpgid setsid sigaction siginterrupt stat64  \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index ac669c940..642b84bee 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -924,6 +924,12 @@ Otherwise they are set to the value specified with 
@var{mode}.
 The return value is unspecified.
 @end deffn
 
+@deffn {Scheme Procedure} mkdirat dir path [mode]
+@deffnx {C Function} scm_mkdirat (dir, path, mode)
+Like @code{mkdir}, but resolve @var{path} relative to the directory
+referred to by the file port @var{dir} instead.
+@end deffn
+
 @deffn {Scheme Procedure} rmdir path
 @deffnx {C Function} scm_rmdir (path)
 Remove the existing directory named by @var{path}.  The directory must
diff --git a/libguile/filesys.c b/libguile/filesys.c
index e00ddba5f..29787a83f 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1351,6 +1351,31 @@ SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
 }
 #undef FUNC_NAME
 
+#ifdef HAVE_MKDIRAT
+SCM_DEFINE (scm_mkdirat, "mkdirat", 2, 1, 0,
+            (SCM dir, SCM path, SCM mode),
+            "Like @code{mkdir}, but resolve @var{path} relative to the 
directory\n"
+            "referred to by the file port @var{dir} instead.")
+#define FUNC_NAME s_scm_mkdirat
+{
+  int rv;
+  int dir_fdes;
+  mode_t c_mode;
+
+  c_mode = SCM_UNBNDP (mode) ? 0777 : scm_to_uint (mode);
+  SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+  dir_fdes = SCM_FPORT_FDES (dir);
+
+  STRING_SYSCALL (path, c_path, rv = mkdirat (dir_fdes, c_path, c_mode));
+  if (rv != 0)
+    SCM_SYSERROR;
+
+  scm_remember_upto_here_1 (dir);
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
 SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, 
             (SCM path),
            "Remove the existing directory named by @var{path}.  The directory 
must\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index d181aca52..f0dd35ede 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -50,6 +50,7 @@ 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_mkdirat (SCM dir, SCM path, SCM mode);
 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/filesys.test b/test-suite/tests/filesys.test
index 64bf92333..4ea62d513 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -29,6 +29,8 @@
   (data-file-name "filesys-test.tmp"))
 (define (test-symlink)
   (data-file-name "filesys-test-link.tmp"))
+(define (test-directory)
+  (data-file-name "filesys-test-dir.tmp"))
 
 
 ;;;
@@ -394,3 +396,39 @@
       (throw 'unsupported))
     (symlinkat (call-with-port (open "." O_RDONLY) identity)
                (test-file) (test-symlink))))
+
+(with-test-prefix "mkdirat"
+  (define (skip-if-unsupported)
+    (unless (defined? 'mkdirat)
+      (throw 'unsupported)))
+  (define (maybe-delete-directory)
+    (when (file-exists? (test-directory))
+      (rmdir (test-directory))))
+  (maybe-delete-directory)
+
+  (pass-if-equal "create" 'directory
+    (skip-if-unsupported)
+    (call-with-port
+     (open "." O_RDONLY)
+     (lambda (port)
+       (mkdirat port (test-directory))
+       (stat:type (stat (test-directory))))))
+  (maybe-delete-directory)
+
+  (pass-if-equal "explicit perms" (logand #o111 (lognot (umask)))
+    (skip-if-unsupported)
+    (call-with-port
+     (open "." O_RDONLY)
+     (lambda (port)
+       (mkdirat port (test-directory) #o111)
+       (stat:perms (stat (test-directory))))))
+  (maybe-delete-directory)
+
+  (pass-if-equal "create, implicit perms" (logand #o777 (lognot (umask)))
+    (skip-if-unsupported)
+    (call-with-port
+     (open "." O_RDONLY)
+     (lambda (port)
+       (mkdirat port (test-directory))
+       (stat:perms (stat (test-directory))))))
+  (maybe-delete-directory))