1 files changed, 94 insertions, 22 deletions

diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml
index 7b27b89a7..f2fbd3a7e 100644
--- a/otherlibs/labltk/browser/shell.ml
+++ b/otherlibs/labltk/browser/shell.ml
@@ -15,6 +15,7 @@
 
 open Tk
 open Jg_tk
+open Dummy
 
 (* Here again, memoize regexps *)
 
@@ -37,6 +38,19 @@ class ['a] history () = object
     List.nth history pos:((l + count - 1) mod l)
 end
 
+let dump_mem ?(:pos = 0) ?:len obj =
+  if not (Obj.is_block obj) then invalid_arg "Shell.dump_mem";
+  let len =
+    match len with
+    | None -> Obj.size obj * Sys.word_size / 8 - pos
+    | Some x -> x in
+  let buf = Buffer.create 256 in
+  for i = pos to len - 1 do
+    let c = String.unsafe_get (Obj.obj obj) i in
+    Buffer.add_string buf (Printf.sprintf "%02x" (Char.code c))
+  done;
+  Buffer.contents buf
+
 (* The shell class. Now encapsulated *)
 
 let protect f x = try f x with _ -> ()
@@ -44,32 +58,52 @@ let protect f x = try f x with _ -> ()
 class shell :textw :prog :args :env =
   let (in2,out1) = Unix.pipe ()
   and (in1,out2) = Unix.pipe ()
-  and (err1,err2) = Unix.pipe () in
+  and (err1,err2) = Unix.pipe ()
+  and (sig2,sig1) = Unix.pipe () in
 object (self)
-  val pid = Unix.create_process_env name:prog :args :env
+  val pid =
+    let env =
+      if Sys.os_type = "Win32" then
+        let sigdef = "CAMLSIGPIPE=" ^ dump_mem (Obj.repr sig2) in
+        Array.append env [|sigdef|]
+      else env
+    in
+    Unix.create_process_env name:prog :args :env
       stdin:in2 stdout:out2 stderr:err2
   val out = Unix.out_channel_of_descr out1
   val h = new history ()
   val mutable alive = true
   val mutable reading = false
+  val ibuffer = Buffer.create 1024
+  val imutex = Mutex.create ()
+  val mutable ithreads = []
   method alive = alive
   method kill =
     if Winfo.exists textw then Text.configure textw state:`Disabled;
     if alive then begin
       alive <- false;
       protect close_out out;
-      List.iter fun:(protect Unix.close) [in1; err1; in2; out2; err2];
       try
-        Fileevent.remove_fileinput fd:in1;
-        Fileevent.remove_fileinput fd:err1;
-        Unix.kill :pid signal:Sys.sigkill;
-        Unix.waitpid mode:[] pid; ()
+        if Sys.os_type = "Win32" then begin
+          ignore (Unix.write sig1 buf:"T" pos:0 len:1);
+          List.iter fun:(protect Unix.close) [sig1; sig2]
+        end else begin
+          List.iter fun:(protect Unix.close) [in1; err1; sig1; sig2];
+          Fileevent.remove_fileinput fd:in1;
+          Fileevent.remove_fileinput fd:err1;
+          Unix.kill :pid signal:Sys.sigkill;
+          Unix.waitpid mode:[] pid; ()
+        end
       with _ -> ()
     end
   method interrupt =
     if alive then try
       reading <- false;
-      Unix.kill :pid signal:Sys.sigint
+      if Sys.os_type = "Win32" then begin
+        ignore (Unix.write sig1 buf:"C" pos:0 len:1);
+        self#send " "
+      end else
+        Unix.kill :pid signal:Sys.sigint
     with Unix.Unix_error _ -> ()
   method send s =
     if alive then try
@@ -77,12 +111,16 @@ object (self)
       flush out
     with Sys_error _ -> ()
   method private read :fd :len =
-    try
+    begin try
       let buf = String.create :len in
       let len = Unix.read fd :buf pos:0 :len in
-      self#insert (String.sub buf pos:0 :len);
-      Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)])
-    with Unix.Unix_error _ -> ()
+      if len > 0 then begin
+	self#insert (String.sub buf pos:0 :len);
+	Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)])
+      end;
+      len
+    with Unix.Unix_error _ -> 0
+    end;
   method history (dir : [`next|`previous]) =
     if not h#empty then begin
       if reading then begin
@@ -151,13 +189,38 @@ object (self)
       end;
     bind textw events:[`KeyPressDetail"Return"] breakable:true
       action:(fun _ -> self#return; break());
-    begin try
-      List.iter [in1;err1] fun:
-        begin fun fd ->
-          Fileevent.add_fileinput :fd
-            callback:(fun () -> self#read :fd len:1024)
-        end
-    with _ -> ()
+    List.iter fun:Unix.close [in2;out2;err2];
+    if Sys.os_type = "Win32" then begin
+      let fileinput_thread fd =
+        let buf = String.create len:1024 in
+        let len = ref 0 in
+        try while len := ThreadUnix.read fd :buf pos:0 len:1024; !len > 0 do
+          Mutex.lock imutex;
+          Buffer.add_substring ibuffer buf pos:0 len:!len;
+          Mutex.unlock imutex
+        done with Unix.Unix_error _ -> ()
+      in
+      ithreads <- List.map [in1; err1] fun:(Thread.create fileinput_thread);
+      let rec read_buffer () =
+        Mutex.lock imutex;
+        if Buffer.length ibuffer > 0 then begin
+          self#insert (Str.global_replace pat:~"\r\n" with:"\n"
+                         (Buffer.contents ibuffer));
+          Buffer.reset ibuffer;
+	  Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)])
+        end;
+        Mutex.unlock imutex;
+        ignore (Timer.add ms:100 callback:read_buffer)
+      in
+      read_buffer ()
+    end else begin
+      try
+	List.iter [in1;err1] fun:
+          begin fun fd ->
+            Fileevent.add_fileinput :fd
+              callback:(fun () -> ignore (self#read :fd len:1024))
+          end
+      with _ -> ()
     end
 end
 
@@ -175,17 +238,26 @@ let get_all () =
   shells := all;
   all
 
-let may_exec prog =
+let may_exec_unix prog =
   try Unix.access name:prog perm:[Unix.X_OK]; true
   with Unix.Unix_error _ -> false
 
+let may_exec_win prog =
+  List.exists pred:may_exec_unix [prog; prog^".exe"; prog^".cmo"; prog^".bat"]
+
+let may_exec =
+  if Sys.os_type = "Win32" then may_exec_win else may_exec_unix
+
+let path_sep = if Sys.os_type = "Win32" then ";" else ":"
+
 let f :prog :title =
   let progargs =
     List.filter pred:((<>) "") (Str.split sep:~" " prog) in
   if progargs = [] then () else
   let prog = List.hd progargs in
-  let path = try Sys.getenv "PATH" with Not_found -> "/bin:/usr/bin" in
-  let exec_path = Str.split sep:~":" path in
+  let path =
+    try Sys.getenv "PATH" with Not_found -> "/bin" ^ path_sep ^ "/usr/bin" in
+  let exec_path = Str.split sep:~path_sep path in
   let exists =
     if not (Filename.is_implicit prog) then may_exec prog else
     List.exists exec_path