01/01: build: syscalls: Add mkdtemp!

[David Thompson]

davexunit pushed a commit to branch master
in repository guix.

commit b4abdeb63b4e29f89a0a8e54f7b442bb31da87c9
Author: David Thompson <address@hidden>
Date:   Wed Jun 24 20:50:34 2015 -0400

    build: syscalls: Add mkdtemp!
    
    * guix/build/syscalls.scm (mkdtemp!): New procedure.
    * tests/syscalls.scm ("mkdtemp!"): New test.
---
 guix/build/syscalls.scm |   15 +++++++++++++++
 tests/syscalls.scm      |    9 +++++++++
 2 files changed, 24 insertions(+), 0 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 6d31510..a464040 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -45,6 +45,7 @@
             swapon
             swapoff
             processes
+            mkdtemp!
 
             IFF_UP
             IFF_BROADCAST
@@ -265,6 +266,20 @@ user-land process."
                     (scandir "/proc"))
         <))
 
+(define mkdtemp!
+  (let* ((ptr  (dynamic-func "mkdtemp" (dynamic-link)))
+         (proc (pointer->procedure '* ptr '(*))))
+    (lambda (tmpl)
+      "Create a new unique directory in the file system using the template
+string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
+      (let ((result (proc (string->pointer tmpl)))
+            (err    (errno)))
+        (when (null-pointer? result)
+          (throw 'system-error "mkdtemp!" "~S: ~A"
+                 (list tmpl (strerror err))
+                 (list err)))
+        (pointer->string result)))))
+
 
 ;;;
 ;;; Packed structures.
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 706f3df..049ca93 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015 David Thompson <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -67,6 +68,14 @@
     (lambda args
       (memv (system-error-errno args) (list EPERM EINVAL ENOENT)))))
 
+(test-assert "mkdtemp!"
+  (let* ((tmp (or (getenv "TMPDIR") "/tmp"))
+         (dir (mkdtemp! (string-append tmp "/guix-test-XXXXXX"))))
+    (and (file-exists? dir)
+         (begin
+           (rmdir dir)
+           #t))))
+
 (test-assert "all-network-interfaces"
   (match (all-network-interfaces)
     (((? string? names) ..1)