[MLton] Temporary directories on MinGW / mlnlffigen

[Vesa Karvonen]

On 4/24/07, Vesa Karvonen <vesa.a.j.k at gmail.com> wrote:
> Hmm... I just noticed the GetTempPath function:
>
>   http://msdn2.microsoft.com/en-us/library/aa364992.aspx
[...]

Below is a patch (excluding generated files) using GetTempPath.  It
introduces a new MinGW specific function MinGW_getTempPath that
returns the result of GetTempPath as a freshly malloced C string.
The C string is freed on the ML side after converting it to a ML
string.  I wonder whether there is some other technique used in
MLton for such functions.

-Vesa Karvonen

Index: runtime/platform/mingw.c
===================================================================
--- runtime/platform/mingw.c	(revision 5538)
+++ runtime/platform/mingw.c	(working copy)
@@ -1024,3 +1024,26 @@
                 return result;
         }
 }
+
+/* ------------------------------------------------- */
+/*                        MinGW                      */
+/* ------------------------------------------------- */
+
+C_String_t MinGW_getTempPath() {
+  C_String_t buffer = NULL;
+
+  DWORD reqSize = GetTempPath(0, NULL);
+  if (!reqSize) goto failed;
+
+  buffer = malloc(reqSize);
+  if (!buffer) goto failed;
+
+  DWORD check = GetTempPath(reqSize, buffer);
+  if (0 == check || reqSize < check) goto failed;
+
+  return buffer;
+
+ failed:
+  free(buffer);
+  return NULL;
+}
Index: runtime/gen/basis-ffi.def
===================================================================
--- runtime/gen/basis-ffi.def	(revision 5538)
+++ runtime/gen/basis-ffi.def	(working copy)
@@ -103,6 +103,7 @@
 MLton.Syslog.closelog = _import : unit -> unit
 MLton.Syslog.openlog = _import : NullString8.t * C_Int.t * C_Int.t -> unit
 MLton.Syslog.syslog = _import : C_Int.t * NullString8.t -> unit
+MinGW.getTempPath = _import : unit -> C_String.t
 Net.htonl = _import : Word32.t -> Word32.t
 Net.htons = _import : Word16.t -> Word16.t
 Net.ntohl = _import : Word32.t -> Word32.t
Index: basis-library/platform/mingw.sml
===================================================================
--- basis-library/platform/mingw.sml	(revision 0)
+++ basis-library/platform/mingw.sml	(revision 0)
@@ -0,0 +1,20 @@
+(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+structure MinGW =
+   struct
+      fun getTempPath () =
+         let
+            val path = PrimitiveFFI.MinGW.getTempPath ()
+            val free = _import "free" : CUtil.C_Pointer.t -> unit ;
+         in
+            if CUtil.C_Pointer.isNull path
+               then NONE
+            else
+               SOME (CUtil.C_String.toString path) before free path
+         end
+   end

Property changes on: basis-library/platform/mingw.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Index: basis-library/mlton/io.sig
===================================================================
--- basis-library/mlton/io.sig	(revision 5538)
+++ basis-library/mlton/io.sig	(working copy)
@@ -26,4 +26,6 @@
       val mkstemp: string -> string * outstream
       (* mkstemps is like mkstemp, except it has both a prefix and suffix. *)
       val mkstemps: {prefix: string, suffix: string} -> string * outstream
+      (* adds a suitable system or user specific prefix (dir) for temp files *)
+      val tempPrefix : string -> string
    end
Index: basis-library/mlton/io.fun
===================================================================
--- basis-library/mlton/io.fun	(revision 5538)
+++ basis-library/mlton/io.fun	(working copy)
@@ -33,4 +33,12 @@

 fun mkstemp s = mkstemps {prefix = s, suffix = ""}

+fun tempPrefix file =
+   case MLtonPlatform.OS.host of
+      MLtonPlatform.OS.MinGW =>
+      (case MinGW.getTempPath () of
+          SOME d => d
+        | NONE => "C:\\temp\\") ^ file
+    | _ => "/tmp/" ^ file
+
 end
Index: basis-library/mlton/mlton.sml
===================================================================
--- basis-library/mlton/mlton.sml	(revision 5538)
+++ basis-library/mlton/mlton.sml	(working copy)
@@ -108,7 +108,8 @@

             fun tmpName () =
                let
-                  val (f, out) = MLton.TextIO.mkstemp "/tmp/file"
+                  val (f, out) =
+                      MLton.TextIO.mkstemp (MLton.TextIO.tempPrefix "file")
                   val _ = TextIO.closeOut out
                in
                   f
Index: basis-library/build/sources.mlb
===================================================================
--- basis-library/build/sources.mlb	(revision 5538)
+++ basis-library/build/sources.mlb	(working copy)
@@ -250,6 +250,9 @@
    ../posix/posix.sml

    ../platform/cygwin.sml
+   ann "allowFFI true" in
+      ../platform/mingw.sml
+   end

    ../io/stream-io.sig
    ../io/stream-io.fun
@@ -318,6 +321,8 @@
    ../net/unix-sock.sig
    ../net/unix-sock.sml

+   ../mlton/platform.sig
+   ../mlton/platform.sml
    ../mlton/array.sig
    ../mlton/cont.sig
    ../mlton/cont.sml
@@ -336,8 +341,6 @@
       ../mlton/ffi.sml
    end
    ../mlton/int-inf.sig
-   ../mlton/platform.sig
-   ../mlton/platform.sml
    ../mlton/proc-env.sig
    ../mlton/proc-env.sml
    ../mlton/profile.sig
Index: lib/mlton-stubs/io.sig
===================================================================
--- lib/mlton-stubs/io.sig	(revision 5538)
+++ lib/mlton-stubs/io.sig	(working copy)
@@ -26,4 +26,6 @@
       val mkstemp: string -> string * outstream
       (* mkstemps is like mkstemp, except it has both a prefix and suffix. *)
       val mkstemps: {prefix: string, suffix: string} -> string * outstream
+      (* adds a suitable system or user specific prefix (dir) for temp files *)
+      val tempPrefix: string -> string
    end
Index: lib/mlton-stubs/mlton.sml
===================================================================
--- lib/mlton-stubs/mlton.sml	(revision 5538)
+++ lib/mlton-stubs/mlton.sml	(working copy)
@@ -25,6 +25,7 @@
       fun newOut _ = raise Fail "newOut"
       fun outFd _ = raise Fail "outFd"
       fun setIn _ = raise Fail "setIn"
+      fun tempPrefix _ = raise Fail "tempPrefix"
    end

 (* This file is just a dummy provided in place of the structure that MLton
@@ -84,6 +85,7 @@
             fun newOut _ = raise Fail "newOut"
             fun outFd _ = raise Fail "outFd"
             fun setIn _ = raise Fail "setIn"
+            fun tempPrefix _ = raise Fail "tempPrefix"
          end

       structure CallStack =
Index: lib/mlton/basic/file.sml
===================================================================
--- lib/mlton/basic/file.sml	(revision 5538)
+++ lib/mlton/basic/file.sml	(working copy)
@@ -88,6 +88,7 @@
            List.foreach (sources, fn f => outputContents (f, out)))

 val temp = MLton.TextIO.mkstemps
+val tempPrefix = MLton.TextIO.tempPrefix

 fun tempName z =
    let
@@ -99,7 +100,7 @@

 fun withTemp f =
    let
-      val name = tempName {prefix = "/tmp/file", suffix = ""}
+      val name = tempName {prefix = tempPrefix "file", suffix = ""}
    in
       Exn.finally (fn () => f name, fn () => remove name)
    end
@@ -116,7 +117,7 @@
    end

 fun withTempOut (f, g) =
-   withTempOut' ({prefix = "/tmp/file", suffix = ""}, f, g)
+   withTempOut' ({prefix = tempPrefix "file", suffix = ""}, f, g)

 fun withString (s, f) =
    withTempOut (fn out => Out.output (out, s), f)
Index: lib/mlton/basic/dir.sml
===================================================================
--- lib/mlton/basic/dir.sml	(revision 5538)
+++ lib/mlton/basic/dir.sml	(working copy)
@@ -85,7 +85,7 @@

 fun inTemp thunk =
    let
-      val d = concat ["/tmp/dir", Random.alphaNumString 6]
+      val d = concat [MLton.TextIO.tempPrefix "dir", Random.alphaNumString 6]
       val _ = make d
    in
       Exn.finally (fn () => inDir (d, fn _ => thunk ()),