New procedure mkdtemp! to create unique temporary directory

* configure.ac (AC_CHECK_FUNCS): add mkdtemp! test
* doc/ref/posix.texi: document mkdtemp!
* libguile/filesys.c (scm_mkdtemp_x): new function
* libguile/filesys.h: new declaration for scm_mkdtemp_x
* test-suite/tests/filesys.test: add tests for mkdtemp!

Adapted from a patch by Rob Browning.

configure.ac

@@ -3,7 +3,7 @@ dnl   Process this file with autoconf to produce configure.
 dnl
 
 define(GUILE_CONFIGURE_COPYRIGHT,[[
-Copyright 1998-2020 Free Software Foundation, Inc.
+Copyright 1998-2021 Free Software Foundation, Inc.
 
 This file is part of Guile.
 
@@ -484,16 +484,16 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
 #   sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
 #   sendfile - non-POSIX, found in glibc
 #
-AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid		\
+AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid         \
-  fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid	\
+  fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid        \
-  gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mknod nice	\
+  gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod   \
-  readlink rename rmdir setegid seteuid		                        \
+  nice readlink rename rmdir setegid seteuid                            \
-  setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64	\
+  setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64  \
-  strptime symlink sync sysconf tcgetpgrp tcsetpgrp uname waitpid	\
+  strptime symlink sync sysconf tcgetpgrp tcsetpgrp uname waitpid       \
-  strdup system usleep atexit on_exit chown link fcntl ttyname getpwent	\
+  strdup system usleep atexit on_exit chown link fcntl ttyname getpwent \
-  getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp	\
+  getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp  \
-  index bcopy memcpy rindex truncate isblank _NSGetEnviron		\
+  index bcopy memcpy rindex truncate isblank _NSGetEnviron              \
-  strcoll strcoll_l strtod_l strtol_l newlocale uselocale utimensat	\
+  strcoll strcoll_l strtod_l strtol_l newlocale uselocale utimensat     \
   sched_getaffinity sched_setaffinity sendfile])
 
 # The newlib C library uses _NL_ prefixed locale langinfo constants.

doc/ref/posix.texi

@@ -1,7 +1,7 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
 @c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
-@c   2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017 Free Software Foundation, Inc.
+@c   2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017, 2021 Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node POSIX
@@ -1020,6 +1020,25 @@ The file is automatically deleted when the port is closed
 or the program terminates.
 @end deffn
 
+@deffn {Scheme Procedure} mkdtemp! tmpl
+@deffnx {C Function} scm_mkdtemp_x (tmpl)
+@cindex temporary directory
+Create a new directory named in accordance with the template string
+@var{tmpl}.
+
+@var{tmpl} is a string specifying the directory's name. The last six
+characters of @var{tmpl} must be @samp{XXXXXX}, characters that will be
+modified to ensure the directory name is unique. Upon successful
+execution, those @samp{X}s will be changed to reflect the name of the
+unique directory created.
+
+The permissions of the directory created are OS dependent, but, are
+usually @code{#o700}.
+
+The return value is unspecified.  An error may be thrown if the template
+has the wrong format or if the directory cannot be created.
+@end deffn
+
 @deffn {Scheme Procedure} dirname filename
 @deffnx {C Function} scm_dirname (filename)
 Return the directory name component of the file name

libguile/filesys.c

@@ -1,4 +1,4 @@
-/* Copyright 1996-2002,2004,2006,2009-2019
+/* Copyright 1996-2002,2004,2006,2009-2019,2021
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -1544,6 +1544,46 @@ scm_mkstemp (SCM tmpl)
   return scm_i_mkstemp (tmpl, SCM_UNDEFINED);
 }
 
+#if HAVE_MKDTEMP
+SCM_DEFINE (scm_mkdtemp_x, "mkdtemp!", 1, 0, 0,
+	    (SCM tmpl),
+            "Create a new unique directory in the file system named in\n"
+            "accordance with @var{tmpl}. The last 6 characters of the\n"
+            "template must be XXXXXX\n"
+            "\n"
+            "Upon success, the template string -- if mutable -- will be\n"
+            "modified in place with the name of the directory created.\n"
+            "The name will also be the return value.\n"
+            "\n"
+            "An error may be thrown if the template is incorrect or if\n"
+            "the directory could not be created.\n")
+#define FUNC_NAME s_scm_mkdtemp_x
+{
+  char *c_tmpl;
+  char *rv;
+
+  SCM_VALIDATE_STRING (SCM_ARG1, tmpl);
+
+  /* Ensure tmpl is mutable.  */
+  scm_i_string_start_writing (tmpl);
+  scm_i_string_stop_writing ();
+
+  scm_dynwind_begin (0);
+  c_tmpl = scm_to_locale_string (tmpl);
+  scm_dynwind_free (c_tmpl);
+  SCM_SYSCALL (rv = mkdtemp (c_tmpl));
+  if (rv == NULL)
+    SCM_SYSERROR;
+  scm_substring_move_x (scm_from_locale_string (c_tmpl),
+			SCM_INUM0, scm_string_length (tmpl),
+			tmpl, SCM_INUM0);
+  scm_dynwind_end ();
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_MKDTEMP */
+
 
 /* Filename manipulation */
 

libguile/filesys.h

@@ -66,6 +66,7 @@ SCM_API SCM scm_readlink (SCM path);
 SCM_API SCM scm_lstat (SCM str);
 SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
 SCM_API SCM scm_mkstemp (SCM tmpl);
+SCM_API SCM scm_mkdtemp_x (SCM tmpl);
 SCM_API SCM scm_dirname (SCM filename);
 SCM_API SCM scm_basename (SCM filename, SCM suffix);
 SCM_API SCM scm_canonicalize_path (SCM path);

test-suite/tests/filesys.test

@@ -231,3 +231,42 @@
 (delete-file (test-file))
 (when (file-exists? (test-symlink))
   (delete-file (test-symlink)))
+
+
+(with-test-prefix "mkdtemp!"
+
+  (pass-if-exception "number arg" exception:wrong-type-arg
+    (if (not (defined? 'mkdtemp!))
+        (throw 'unresolved)
+        (mkdtemp! 123)))
+
+  (pass-if "directory name template prefix is unmodified"
+    (if (not (defined? 'mkdtemp!))
+        (throw 'unresolved)
+        (let ((template (string-copy "T-XXXXXX")))
+          (mkdtemp! template)
+          (false-if-exception (rmdir template))
+          (and
+           (string? template)
+           (string-contains template "T-")
+           (= (string-length template) 8)))))
+
+  (pass-if-exception "read-only template" exception:miscellaneous-error
+    (if (not (defined? 'mkdtemp!))
+        (throw 'unresolved)
+        (mkdtemp! (substring/read-only "T-XXXXXX" 0))))
+
+  (pass-if-exception "invalid template" exception:system-error
+    (if (not (defined? 'mkdtemp!))
+        (throw 'unresolved)
+        (mkdtemp! (string-copy "T-AAAAAA" 0))))
+
+  (pass-if "directory created"
+    (if (not (defined? 'mkdtemp!))
+        (throw 'unresolved)
+        (let ((template (string-copy "T-XXXXXX")))
+          (mkdtemp! template)
+          (let* ((_stat    (stat template))
+                 (result   (eqv? 'directory (stat:type _stat))))
+            (false-if-exception (rmdir template))
+            result)))))