>From 91a046e37c18d08cc3c2d9df2feaa0258aaebd0b Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sun, 3 Aug 2014 14:52:32 +0200
Subject: [PATCH] Fix file-mkstemp behaviour on Windows (#819).

Before, it would return "random" invalid file descriptors.

Thanks to Michele La Monaca for the initial patch.
---
 NEWS         |    2 ++
 posixwin.scm |   41 +++++++++++++++++++++++++++++++----------
 2 files changed, 33 insertions(+), 10 deletions(-)

diff --git a/NEWS b/NEWS
index 20ece38..d613613 100644
--- a/NEWS
+++ b/NEWS
@@ -21,6 +21,8 @@
 - Unit "posix":
   - set-file-position! now allows negative positions for seek/cur (thanks
     to Seth Alves).
+  - file-mkstemp now works correctly on Windows, it now returns valid
+    file descriptors (#819, thanks to Michele La Monaca).
 
 - Runtime system:
   - Removed several deprecated, undocumented parts of the C interface:
diff --git a/posixwin.scm b/posixwin.scm
index c41e18d..2f29269 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -198,7 +198,6 @@ readdir(DIR * dir)
 #endif /* ifndef __WATCOMC__ */
 
 #ifdef __WATCOMC__
-# define mktemp _mktemp
 /* there is no P_DETACH in Watcom CRTL */
 # define P_DETACH P_NOWAIT
 #endif
@@ -256,7 +255,6 @@ C_free_arg_string(char **where) {
 #define C_open(fn, fl, m)   C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
 #define C_read(fd, b, n)    C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
 #define C_write(fd, b, n)   C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
-#define C_mkstemp(t)	    C_fix(mktemp(C_c_string(t)))
 
 #define C_flushall()	    C_fix(_flushall())
 
@@ -778,14 +776,37 @@ EOF
 (define file-mkstemp
   (lambda (template)
     (##sys#check-string template 'file-mkstemp)
-    (let* ([buf (##sys#make-c-string template 'file-mkstemp)]
-	   [fd (##core#inline "C_mkstemp" buf)]
-	   [path-length (string-length buf)])
-      (when (eq? -1 fd)
-	(##sys#update-errno)
-	(##sys#signal-hook #:file-error 'file-mkstemp "cannot create temporary file" template) )
-      (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )
-
+    (let* ((diz "0123456789abcdefghijklmnopqrstuvwxyz")
+           (diz-len (string-length diz))
+           (max-attempts (* diz-len diz-len diz-len))
+           (tmpl (string-copy template)) ; We'll overwrite this later
+	   (tmpl-len (string-length tmpl))
+           (first-x (let loop ((i (fx- tmpl-len 1)))
+		      (if (and (fx>= i 0)
+			       (eq? (string-ref tmpl i) #\X))
+			  (loop (fx- i 1))
+			  (fx+ i 1)))))
+      (cond ((not (directory-exists? (or (pathname-directory template) ".")))
+	     ;; Quit early instead of looping needlessly with C_open
+	     ;; failing every time.  This is a race condition, but not
+	     ;; a security-critical one.
+	     (##sys#error 'mkstemp "non-existent directory"))
+	    ((fx= first-x tmpl-len)
+	     (##sys#error 'mkstemp "invalid template")))
+      (let loop ((count 1))
+	(let suffix-loop ((index (fx- tmpl-len 1)))
+	  (when (fx>= index first-x)
+	    (string-set! tmpl index (string-ref diz (random diz-len)))
+	    (suffix-loop (fx- index 1))))
+	(let ((fd (##core#inline "C_open"
+				 (##sys#make-c-string tmpl 'file-open)
+				 (bitwise-ior open/rdwr open/creat open/excl)
+				 (fxior _s_irusr _s_iwusr))))
+	  (if (eq? -1 fd)
+	      (if (fx< count max-attempts)
+		  (loop (fx+ count 1))
+		  (##sys#error 'mkstemp "max attempts reached"))
+	      (values fd tmpl)))))))
 
 ;;; Directory stuff:
 
-- 
1.7.10.4