[MLton-commit] r6699

[Wesley Terpstra]

As reported by Nicolas Bertolotti, the escape function for shell arguments was
broken on MinGW. This patch corrects it. It might still be broken on cygwin.


----------------------------------------------------------------------

U   mlton/trunk/basis-library/mlton/process.sml
A   mlton/trunk/regression/spawn.ok
A   mlton/trunk/regression/spawn.sml

----------------------------------------------------------------------

Modified: mlton/trunk/basis-library/mlton/process.sml
===================================================================
--- mlton/trunk/basis-library/mlton/process.sml	2008-08-08 16:03:08 UTC (rev 6698)
+++ mlton/trunk/basis-library/mlton/process.sml	2008-08-11 23:11:23 UTC (rev 6699)
@@ -251,13 +251,40 @@
                end
           | SOME pid => pid (* parent *)
 
-      val dquote = "\""
-      fun cmdEscape y = 
-         concat [dquote,
+      fun strContains seps s =
+        CharVector.exists (Char.contains seps) s
+      (* In MinGW, a string must be escaped if it contains " \t" or is "".
+       * Escaping means adds "s on the front and end. Any quotes inside
+       * must be escaped with \. Any \s already in the string must be
+       * doubled ONLY when they precede a " or the end of string.
+       *)
+      fun mingwEscape (l, 0) = l
+        | mingwEscape (l, i) = mingwEscape (#"\\"::l, i-1)
+      fun mingwFold (#"\\", (l, escapeCount)) = (#"\\"::l, escapeCount+1)
+        | mingwFold (#"\"", (l, escapeCount)) = 
+            (#"\"" :: mingwEscape (#"\\"::l, escapeCount), 0)
+        | mingwFold (x, (l, _)) = (x :: l, 0)
+      val mingwQuote = mingwEscape o CharVector.foldl mingwFold ([#"\""], 0)
+      fun mingwEscape y =
+         if not (strContains " \t\"" y) andalso y<>"" then y else
+         String.implode (List.rev (#"\"" :: mingwQuote y))
+
+      (* In cygwin, according to what I read, \ should always become \\.
+       * Furthermore, more characters cause escaping as compared to MinGW. 
+       * From what I read, " should become "", not \", but I leave the old
+       * behaviour alone until someone runs the spawn regression.
+       *)
+      fun cygwinEscape y = 
+         if not (strContains " \t\"\r\n\f'" y) andalso y<>"" then y else
+         concat ["\"",
                  String.translate
                  (fn #"\"" => "\\\"" | #"\\" => "\\\\" | x => String.str x) y,
-                 dquote]
+                 "\""]
 
+      val cmdEscape = 
+         if MLton.Platform.OS.host = MLton.Platform.OS.MinGW
+         then mingwEscape else cygwinEscape
+
       fun create (cmd, args, env, stdin, stdout, stderr) =
          SysCall.simpleResult'
          ({errVal = C_PId.castFromFixedInt ~1}, fn () =>

Added: mlton/trunk/regression/spawn.ok
===================================================================
--- mlton/trunk/regression/spawn.ok	2008-08-08 16:03:08 UTC (rev 6698)
+++ mlton/trunk/regression/spawn.ok	2008-08-11 23:11:23 UTC (rev 6699)
@@ -0,0 +1 @@
+OK!

Added: mlton/trunk/regression/spawn.sml
===================================================================
--- mlton/trunk/regression/spawn.sml	2008-08-08 16:03:08 UTC (rev 6698)
+++ mlton/trunk/regression/spawn.sml	2008-08-11 23:11:23 UTC (rev 6699)
@@ -0,0 +1,34 @@
+val tests = [
+  "\"hello\\\"",
+  "c:\\foo.bah",
+  "",
+  "hi\\",
+  "hi\"",
+  "evil\narg",
+  "evil\targ",
+  "evil arg",
+  "evil\rarg",
+  "evil\farg",
+  "\"bar\\",
+  "\\bah",
+  "bah \\bar",
+  "bah\\bar",
+  "bah\\\\",
+  "ba h\\\\",
+  "holy\"smoke",
+  "holy \"smoke" ]
+
+val args = CommandLine.arguments ()
+
+fun loop ([], []) = print "OK!\n"
+  | loop (x::r, y::s) = 
+      (if x <> y then print ("FAIL: "^x^":"^y^"\n") else (); loop (r, s))
+  | loop (_, _) = print "Wrong argument count\n"
+
+open Posix.Process
+open MLton.Process
+val () =
+  if List.length args = 0
+  then ignore (waitpid (W_CHILD (spawn { path = "spawn", args = "spawn"::tests }), []))
+  else loop (tests, args)
+