[Unison-hackers] [unison-svn] r337 - in trunk/src: . lwt system system/generic
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Tue May 26 05:38:25 EDT 2009
Author: vouillon
Date: 2009-05-26 05:38:19 -0400 (Tue, 26 May 2009)
New Revision: 337
Modified:
trunk/src/.depend
trunk/src/Makefile.OCaml
trunk/src/RECENTNEWS
trunk/src/external.ml
trunk/src/files.ml
trunk/src/lwt/lwt_unix.ml
trunk/src/lwt/lwt_unix.mli
trunk/src/mkProjectInfo.ml
trunk/src/remote.ml
trunk/src/system/
trunk/src/system/generic/
trunk/src/system/system_generic.ml
trunk/src/system/system_intf.ml
trunk/src/system/system_win.ml
trunk/src/system/system_win_stubs.c
trunk/src/terminal.ml
trunk/src/uigtk2.ml
trunk/src/uitext.ml
trunk/src/unicode.ml
trunk/src/unicode.mli
Log:
* Use system dependant API for spawning processes.
(Unicode API under Windows.)
* Fixed the bug with ssh not working when running unison from a cygwin
shell.
* Move [protect] function (which converts a string to UTF-8 by keeping
all UTF-8 characters unchanged and considering all other characters
as ISO 8859-1 characters) from uigtk2.ml to unicode.ml, as it may be
useful for the other UIs.
Modified: trunk/src/.depend
===================================================================
--- trunk/src/.depend 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/.depend 2009-05-26 09:38:19 UTC (rev 337)
@@ -65,9 +65,9 @@
ubase/safelist.cmx remote.cmx props.cmx ubase/prefs.cmx path.cmx osx.cmx \
os.cmx lwt/lwt_util.cmx lwt/lwt.cmx globals.cmx fspath.cmx fs.cmx \
fileinfo.cmx external.cmx common.cmx clroot.cmx abort.cmx copy.cmi
-external.cmo: ubase/util.cmi ubase/safelist.cmi lwt/lwt_util.cmi \
+external.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi lwt/lwt_util.cmi \
lwt/lwt_unix.cmi lwt/lwt.cmi external.cmi
-external.cmx: ubase/util.cmx ubase/safelist.cmx lwt/lwt_util.cmx \
+external.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx lwt/lwt_util.cmx \
lwt/lwt_unix.cmx lwt/lwt.cmx external.cmi
fileinfo.cmo: ubase/util.cmi system.cmi props.cmi ubase/prefs.cmi path.cmi \
osx.cmi fspath.cmi fs.cmi fileinfo.cmi
@@ -169,10 +169,10 @@
strings.cmx: strings.cmi
system.cmo: system.cmi
system.cmx: system.cmi
-terminal.cmo: ubase/safelist.cmi ubase/rx.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
- terminal.cmi
-terminal.cmx: ubase/safelist.cmx ubase/rx.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
- terminal.cmi
+terminal.cmo: system.cmi ubase/safelist.cmi ubase/rx.cmi lwt/lwt_unix.cmi \
+ lwt/lwt.cmi terminal.cmi
+terminal.cmx: system.cmx ubase/safelist.cmx ubase/rx.cmx lwt/lwt_unix.cmx \
+ lwt/lwt.cmx terminal.cmi
test.cmo: uutil.cmi ubase/util.cmi update.cmi uicommon.cmi transport.cmi \
ubase/trace.cmi stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi \
ubase/prefs.cmi path.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi \
@@ -207,16 +207,16 @@
recon.cmx props.cmx ubase/prefs.cmx path.cmx osx.cmx os.cmx name.cmx \
lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx files.cmx \
fileinfo.cmx common.cmx clroot.cmx case.cmx uicommon.cmi
-uigtk2.cmo: uutil.cmi ubase/util.cmi update.cmi uitext.cmi uicommon.cmi \
- transport.cmi ubase/trace.cmi system.cmi strings.cmi sortri.cmi \
- ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi pixmaps.cmo \
- path.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi \
- files.cmi common.cmi clroot.cmi case.cmi uigtk2.cmi
-uigtk2.cmx: uutil.cmx ubase/util.cmx update.cmx uitext.cmx uicommon.cmx \
- transport.cmx ubase/trace.cmx system.cmx strings.cmx sortri.cmx \
- ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx pixmaps.cmx \
- path.cmx os.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx \
- files.cmx common.cmx clroot.cmx case.cmx uigtk2.cmi
+uigtk2.cmo: uutil.cmi ubase/util.cmi update.cmi unicode.cmi uitext.cmi \
+ uicommon.cmi transport.cmi ubase/trace.cmi system.cmi strings.cmi \
+ sortri.cmi ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi \
+ pixmaps.cmo path.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
+ globals.cmi files.cmi common.cmi clroot.cmi case.cmi uigtk2.cmi
+uigtk2.cmx: uutil.cmx ubase/util.cmx update.cmx unicode.cmx uitext.cmx \
+ uicommon.cmx transport.cmx ubase/trace.cmx system.cmx strings.cmx \
+ sortri.cmx ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx \
+ pixmaps.cmx path.cmx os.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
+ globals.cmx files.cmx common.cmx clroot.cmx case.cmx uigtk2.cmi
uigtk.cmo: uutil.cmi ubase/util.cmi update.cmi uitext.cmi uicommon.cmi \
transport.cmi ubase/trace.cmi system.cmi strings.cmi sortri.cmi \
ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi pixmaps.cmo \
Modified: trunk/src/Makefile.OCaml
===================================================================
--- trunk/src/Makefile.OCaml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/Makefile.OCaml 2009-05-26 09:38:19 UTC (rev 337)
@@ -283,8 +283,8 @@
# Include an automatically generated list of dependencies
include .depend
# Additional dependencied depending on the system
-system.cmo fs.cmo: system/$(SYSTEM)/system_impl.cmo
-system.cmx fs.cmx: system/$(SYSTEM)/system_impl.cmx
+system.cmo fspath.cmo fs.cmo: system/$(SYSTEM)/system_impl.cmo
+system.cmx fspath.cmx fs.cmx: system/$(SYSTEM)/system_impl.cmx
ifeq ($(OSARCH), OpenBSD)
ifeq ($(shell echo type ocamldot | ksh), file)
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/RECENTNEWS 2009-05-26 09:38:19 UTC (rev 337)
@@ -1,5 +1,17 @@
CHANGES FROM VERSION 2.34.0
+* Use system dependant API for spawning processes.
+ (Unicode API under Windows.)
+* Fixed the bug with ssh not working when running unison from a cygwin
+ shell.
+* Move [protect] function (which converts a string to UTF-8 by keeping
+ all UTF-8 characters unchanged and considering all other characters
+ as ISO 8859-1 characters) from uigtk2.ml to unicode.ml, as it may be
+ useful for the other UIs.
+
+-------------------------------
+CHANGES FROM VERSION 2.34.0
+
* Small documentation fix suggested by mszsummer.
Modified: trunk/src/external.ml
===================================================================
--- trunk/src/external.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/external.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -64,9 +64,9 @@
let runExternalProgram cmd =
if Util.osType = `Win32 && not Util.isCygwin then begin
debug (fun()-> Util.msg "Executing external program windows-style\n");
- let c = Unix.open_process_in ("\"" ^ cmd ^ "\"") in
+ let c = System.open_process_in ("\"" ^ cmd ^ "\"") in
let log = readChannelTillEof c in
- let returnValue = Unix.close_process_in c in
+ let returnValue = System.close_process_in c in
let mergeResultLog =
cmd ^
(if log <> "" then "\n\n" ^ log else "") ^
@@ -76,12 +76,12 @@
"") in
(returnValue,mergeResultLog)
end else Lwt_unix.run (
- Lwt_unix.open_process_full cmd (Unix.environment ())
- >>= (fun (out, ipt, err) ->
+ let (out, ipt, err) as desc = System.open_process_full cmd in
+ let out = Lwt_unix.intern_in_channel out in
+ let err = Lwt_unix.intern_in_channel err in
readChannelsTillEof [out;err]
>>= (function [logOut;logErr] ->
- Lwt_unix.close_process_full (out, ipt, err)
- >>= (fun returnValue ->
+ let returnValue = System.close_process_full desc in
let logOut = Util.trimWhitespace logOut in
let logErr = Util.trimWhitespace logErr in
return (returnValue, (
@@ -92,6 +92,6 @@
else logOut ^ "\n\n" ^ ("Error Output:" ^ logErr))
^ (if returnValue = Unix.WEXITED 0
then ""
- else "\n\n" ^ Util.process_status_to_string returnValue))))
+ else "\n\n" ^ Util.process_status_to_string returnValue)))
(* Stop typechechecker from complaining about non-exhaustive pattern above *)
- | _ -> assert false)))
+ | _ -> assert false))
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/files.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -496,9 +496,7 @@
Util.replacesubstrings (Prefs.read diffCmd)
["CURRENT1", Fspath.quotes fspath1;
"CURRENT2", Fspath.quotes fspath2] in
- (* Doesn't seem to work well on Windows!
- let c = Lwt_unix.run (Lwt_unix.open_process_in cmd) in *)
- let c = Unix.open_process_in
+ let c = System.open_process_in
(if Util.osType = `Win32 && not Util.isCygwin then
(* BCP: Proposed by Karl M. to deal with the standard windows
command processor's weird treatment of spaces and quotes: *)
@@ -506,7 +504,7 @@
else
cmd) in
showDiff cmd (External.readChannelTillEof c);
- ignore (Unix.close_process_in c) in
+ ignore (System.close_process_in c) in
let (desc1, fp1, ress1, desc2, fp2, ress2) = Common.fileInfos ui1 ui2 in
match root1,root2 with
(Local,fspath1),(Local,fspath2) ->
Modified: trunk/src/lwt/lwt_unix.ml
===================================================================
--- trunk/src/lwt/lwt_unix.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/lwt/lwt_unix.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -291,6 +291,12 @@
type lwt_in_channel = in_channel
type lwt_out_channel = out_channel
+let intern_in_channel ch =
+ Unix.set_nonblock (Unix.descr_of_in_channel ch); ch
+let intern_out_channel ch =
+ Unix.set_nonblock (Unix.descr_of_out_channel ch); ch
+
+
let wait_inchan ic = wait_read (Unix.descr_of_in_channel ic)
let wait_outchan oc = wait_write (Unix.descr_of_out_channel oc)
Modified: trunk/src/lwt/lwt_unix.mli
===================================================================
--- trunk/src/lwt/lwt_unix.mli 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/lwt/lwt_unix.mli 2009-05-26 09:38:19 UTC (rev 337)
@@ -49,6 +49,9 @@
type lwt_in_channel
type lwt_out_channel
+val intern_in_channel : in_channel -> lwt_in_channel
+val intern_out_channel : out_channel -> lwt_out_channel
+
val input_char : lwt_in_channel -> char Lwt.t
val input_line : lwt_in_channel -> string Lwt.t
val input : lwt_in_channel -> string -> int -> int -> int Lwt.t
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/mkProjectInfo.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -151,3 +151,4 @@
+
Modified: trunk/src/remote.ml
===================================================================
--- trunk/src/remote.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/remote.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -899,12 +899,13 @@
debug (fun ()-> Util.msg "Shell connection: %s (%s)\n"
shellCmd (String.concat ", " args));
let term =
+ Util.convertUnixErrorsToFatal "starting shell connection" (fun () ->
match termInteract with
None ->
- ignore (Unix.create_process shellCmd argsarray i1 o2 Unix.stderr);
+ ignore (System.create_process shellCmd argsarray i1 o2 Unix.stderr);
None
| Some callBack ->
- fst (Terminal.create_session shellCmd argsarray i1 o2 Unix.stderr)
+ fst (Terminal.create_session shellCmd argsarray i1 o2 Unix.stderr))
in
Unix.close i1; Unix.close o2;
begin match term, termInteract with
Property changes on: trunk/src/system
___________________________________________________________________
Name: svn:ignore
+ *.cmi
*.cmo
*.cmx
Property changes on: trunk/src/system/generic
___________________________________________________________________
Name: svn:ignore
+ *.cmi
*.cmo
*.cmx
Modified: trunk/src/system/system_generic.ml
===================================================================
--- trunk/src/system/system_generic.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/system/system_generic.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -61,3 +61,13 @@
let file_exists = Sys.file_exists
let open_in_bin = open_in_bin
+
+(****)
+
+let create_process = Unix.create_process
+let open_process_in = Unix.open_process_in
+let open_process_out = Unix.open_process_out
+let open_process_full cmd = Unix.open_process_full cmd (Unix.environment ())
+let close_process_in = Unix.close_process_in
+let close_process_out = Unix.close_process_out
+let close_process_full = Unix.close_process_full
Modified: trunk/src/system/system_intf.ml
===================================================================
--- trunk/src/system/system_intf.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/system/system_intf.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -67,4 +67,16 @@
val chdir : fspath -> unit
val getcwd : unit -> fspath
+val create_process :
+ string -> string array ->
+ Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> int
+val open_process_in : string -> in_channel
+val open_process_out : string -> out_channel
+val open_process_full :
+ string -> in_channel * out_channel * in_channel
+val close_process_in : in_channel -> Unix.process_status
+val close_process_out : out_channel -> Unix.process_status
+val close_process_full :
+ in_channel * out_channel * in_channel -> Unix.process_status
+
end
Modified: trunk/src/system/system_win.ml
===================================================================
--- trunk/src/system/system_win.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/system/system_win.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -17,19 +17,19 @@
(*XXXX
-We have to propagate the encoding mode when canonizing roots
-===> new major version
+Backport to stable:
+- Unix.select in lwt_unix (after some testing...)
+- fix to daylight saving changes
-TO CONVERT
-==========
-Unix.open_process_in
-Unix.open_process_out
-Unix.create_process
-Unix.execvp
-Lwt_unix.open_process_full
-Lwt_unix.open_process_in
+Try to rename several time if access denied the first time
+Remove 16Mib limit by using a temp file (or bigarray)
+http://caml.inria.fr/pub/ml-archives/caml-list/2004/06/2176c54608c3c39e2dbbd9365c2fc6bb.en.html
+http://caml.inria.fr/pub/ml-archives/caml-list/2007/01/04ef3c364e41f5f60f70192609d87035.en.html
+
- Use SetConsoleOutputCP/SetConsoleCP in text mode ???
+http://www.codeproject.com/KB/cpp/unicode_console_output.aspx?display=Print
+
*)
type fspath = string
@@ -190,3 +190,100 @@
sys_error e
let open_in_bin f = open_in_gen [Open_rdonly; Open_binary] 0 f
+
+(****)
+
+external win_create_process :
+ string -> string -> string ->
+ Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> int
+ = "w_create_process" "w_create_process_native"
+
+let make_cmdline args =
+ let maybe_quote f =
+ if String.contains f ' ' || String.contains f '\"'
+ then Filename.quote f
+ else f in
+ String.concat " " (List.map maybe_quote (Array.to_list args))
+
+let create_process prog args fd1 fd2 fd3 =
+ win_create_process
+ prog (utf16 prog) (utf16 (make_cmdline args)) fd1 fd2 fd3
+
+(****)
+
+(* The following is by Xavier Leroy and Pascal Cuoq,
+ projet Cristal, INRIA Rocquencourt.
+ Taken from the Objective Caml win32unix library. *)
+
+type popen_process =
+ Process of in_channel * out_channel
+ | Process_in of in_channel
+ | Process_out of out_channel
+ | Process_full of in_channel * out_channel * in_channel
+
+let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
+
+let open_proc cmd proc input output error =
+ let shell =
+ try getenv "COMSPEC"
+ with Not_found -> raise(Unix.Unix_error(Unix.ENOEXEC, "open_proc", cmd)) in
+ let pid =
+ win_create_process
+ shell (utf16 shell) (utf16 (shell ^ " /c " ^ cmd)) input output error in
+ Hashtbl.add popen_processes proc pid
+
+let open_process_in cmd =
+ let (in_read, in_write) = Unix.pipe() in
+ Unix.set_close_on_exec in_read;
+ let inchan = Unix.in_channel_of_descr in_read in
+ open_proc cmd (Process_in inchan) Unix.stdin in_write Unix.stderr;
+ Unix.close in_write;
+ inchan
+
+let open_process_out cmd =
+ let (out_read, out_write) = Unix.pipe() in
+ Unix.set_close_on_exec out_write;
+ let outchan = Unix.out_channel_of_descr out_write in
+ open_proc cmd (Process_out outchan) out_read Unix.stdout Unix.stderr;
+ Unix.close out_read;
+ outchan
+
+let open_process_full cmd =
+ let (in_read, in_write) = Unix.pipe() in
+ let (out_read, out_write) = Unix.pipe() in
+ let (err_read, err_write) = Unix.pipe() in
+ Unix.set_close_on_exec in_read;
+ Unix.set_close_on_exec out_write;
+ Unix.set_close_on_exec err_read;
+ let inchan = Unix.in_channel_of_descr in_read in
+ let outchan = Unix.out_channel_of_descr out_write in
+ let errchan = Unix.in_channel_of_descr err_read in
+ open_proc cmd (Process_full(inchan, outchan, errchan))
+ out_read in_write err_write;
+ Unix.close out_read; Unix.close in_write; Unix.close err_write;
+ (inchan, outchan, errchan)
+
+let find_proc_id fun_name proc =
+ try
+ let pid = Hashtbl.find popen_processes proc in
+ Hashtbl.remove popen_processes proc;
+ pid
+ with Not_found ->
+ raise(Unix.Unix_error(Unix.EBADF, fun_name, ""))
+
+let close_process_in inchan =
+ let pid = find_proc_id "close_process_in" (Process_in inchan) in
+ close_in inchan;
+ snd(Unix.waitpid [] pid)
+
+let close_process_out outchan =
+ let pid = find_proc_id "close_process_out" (Process_out outchan) in
+ close_out outchan;
+ snd(Unix.waitpid [] pid)
+
+let close_process_full (inchan, outchan, errchan) =
+ let pid =
+ find_proc_id "close_process_full"
+ (Process_full(inchan, outchan, errchan)) in
+ close_in inchan; close_out outchan; close_in errchan;
+ snd(Unix.waitpid [] pid)
Modified: trunk/src/system/system_win_stubs.c
===================================================================
--- trunk/src/system/system_win_stubs.c 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/system/system_win_stubs.c 2009-05-26 09:38:19 UTC (rev 337)
@@ -23,6 +23,8 @@
#include <stdio.h>
#include <windows.h>
+#define NT_MAX_PATH 32768
+
#define Nothing ((value) 0)
struct filedescr {
@@ -293,28 +295,24 @@
CAMLprim value win_getcwd (value unit)
{
int res;
- LPWSTR s;
+ wchar_t s[NT_MAX_PATH];
CAMLparam0();
CAMLlocal1 (path);
- s = stat_alloc (32768 * 2);
- res = GetCurrentDirectoryW (32768, s);
+ res = GetCurrentDirectoryW (NT_MAX_PATH, s);
if (res == 0) {
- stat_free (s);
win32_maperr(GetLastError());
uerror("getcwd", Nothing);
}
/* Normalize the path */
- res = GetLongPathNameW (s, s, 32768);
+ res = GetLongPathNameW (s, s, NT_MAX_PATH);
if (res == 0) {
- stat_free (s);
win32_maperr(GetLastError());
uerror("getcwd", Nothing);
}
/* Convert the drive letter to uppercase */
if (s[0] >= L'a' && s[0] <= L'z') s[0] -= 32;
path = copy_wstring(s);
- stat_free (s);
CAMLreturn (path);
}
@@ -428,3 +426,59 @@
LocalFree (l);
CAMLreturn (res);
}
+
+CAMLprim value w_create_process_native
+(value prog, value wprog, value wargs, value fd1, value fd2, value fd3)
+{
+ int res, flags;
+ PROCESS_INFORMATION pi;
+ STARTUPINFOW si;
+ wchar_t fullname [MAX_PATH];
+ HANDLE h;
+ CAMLparam5(wprog, wargs, fd1, fd2, fd3);
+
+ res = SearchPathW (NULL, (LPCWSTR) String_val(wprog), L".exe",
+ MAX_PATH, fullname, NULL);
+ if (res == 0) {
+ win32_maperr (GetLastError ());
+ uerror("create_process", prog);
+ }
+
+ ZeroMemory(&si, sizeof(STARTUPINFO));
+
+ si.cb = sizeof(STARTUPINFO);
+ si.dwFlags = STARTF_USESTDHANDLES;
+ si.hStdInput = Handle_val(fd1);
+ si.hStdOutput = Handle_val(fd2);
+ si.hStdError = Handle_val(fd3);
+
+ flags = GetPriorityClass (GetCurrentProcess ());
+ /*
+ h = CreateFile ("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
+ OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
+ if (h != INVALID_HANDLE_VALUE)
+ CloseHandle (h);
+ else {
+ flags |= CREATE_NEW_CONSOLE;
+ // si.dwFlags |= STARTF_USESHOWWINDOW;
+ // si.wShowWindow = SW_MINIMIZE;
+ }
+ */
+
+ res = CreateProcessW (fullname, (LPWSTR) String_val(wargs),
+ NULL, NULL, TRUE, flags,
+ NULL, NULL, &si, &pi);
+ if (res == 0) {
+ win32_maperr (GetLastError ());
+ uerror("create_process", prog);
+ }
+
+ CloseHandle (pi.hThread);
+ CAMLreturn (Val_long (pi.hProcess));
+}
+
+CAMLprim value w_create_process(value * argv, int argn)
+{
+ return w_create_process_native(argv[0], argv[1], argv[2],
+ argv[3], argv[4], argv[5]);
+}
Modified: trunk/src/terminal.ml
===================================================================
--- trunk/src/terminal.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/terminal.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -183,7 +183,7 @@
match openpty () with
None ->
(None,
- Unix.create_process cmd args new_stdin new_stdout new_stderr)
+ System.create_process cmd args new_stdin new_stdout new_stderr)
| Some (masterFd, slaveFd) ->
(*
Printf.printf "openpty returns %d--%d\n" (dumpFd fdM) (dumpFd fdS); flush stdout;
Modified: trunk/src/uigtk2.ml
===================================================================
--- trunk/src/uigtk2.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/uigtk2.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -226,101 +226,25 @@
(****)
-let wf_utf8 =
- [[('\x01', '\x7F')];
- [('\xC2', '\xDF'); ('\x80', '\xBF')];
- [('\xE0', '\xE0'); ('\xA0', '\xBF'); ('\x80', '\xBF')];
- [('\xE1', '\xEC'); ('\x80', '\xBF'); ('\x80', '\xBF')];
- [('\xED', '\xED'); ('\x80', '\x9F'); ('\x80', '\xBF')];
- [('\xEE', '\xEF'); ('\x80', '\xBF'); ('\x80', '\xBF')];
- [('\xF0', '\xF0'); ('\x90', '\xBF'); ('\x80', '\xBF'); ('\x80', '\xBF')];
- [('\xF1', '\xF3'); ('\x80', '\xBF'); ('\x80', '\xBF'); ('\x80', '\xBF')];
- [('\xF4', '\xF4'); ('\x80', '\x8F'); ('\x80', '\xBF'); ('\x80', '\xBF')]]
-
-let rec accept_seq l s i len =
- match l with
- [] ->
- Some i
- | (a, b) :: r ->
- if i = len || s.[i] < a || s.[i] > b then
- None
- else
- accept_seq r s (i + 1) len
-
-let rec accept_rec l s i len =
- match l with
- [] ->
- None
- | seq :: r ->
- match accept_seq seq s i len with
- None -> accept_rec r s i len
- | res -> res
-
-let accept = accept_rec wf_utf8
-
-(***)
-
-let rec validate_rec s i len =
- i = len ||
- match accept s i len with
- Some i -> validate_rec s i len
- | None -> false
-
-let expl f s = f s 0 (String.length s)
-
-let validate = expl validate_rec
-
-(****)
-
-let protect_char buf c =
- if c = '\x00' then
- Buffer.add_char buf ' '
- else if c < '\x80' then
- Buffer.add_char buf c
- else
- let c = Char.code c in
- Buffer.add_char buf (Char.chr (c lsr 6 + 0xC0));
- Buffer.add_char buf (Char.chr (c land 0x3f + 0x80))
-
-let rec protect_rec buf s i len =
- if i = len then
- Buffer.contents buf
- else
- match accept s i len with
- Some i' ->
- Buffer.add_substring buf s i (i' - i);
- protect_rec buf s i' len
- | None ->
- protect_char buf s.[i];
- protect_rec buf s (i + 1) len
-
-(* Convert a string to UTF8 by keeping all UTF8 characters unchanged
- and considering all other characters as ISO 8859-1 characters *)
-let protect s =
- let buf = Buffer.create (String.length s * 2) in
- expl (protect_rec buf) s
-
-(****)
-
let escapeMarkup s = Glib.Markup.escape_text s
-let transcode s =
+let transcodeFilename s =
if Prefs.read Case.unicodeEncoding then
- protect s
- else
+ Unicode.protect s
+ else if Util.osType = `Win32 then transcodeDoc s else
try
- Glib.Convert.locale_to_utf8 s
+ Glib.Convert.filename_to_utf8 s
with Glib.Convert.Error _ ->
- protect s
+ Unicode.protect s
-let transcodeFilename s =
+let transcode s =
if Prefs.read Case.unicodeEncoding then
- protect s
- else if Util.osType = `Win32 then transcode s else
+ Unicode.protect s
+ else
try
- Glib.Convert.filename_to_utf8 s
+ Glib.Convert.locale_to_utf8 s
with Glib.Convert.Error _ ->
- protect s
+ Unicode.protect s
(**********************************************************************
USEFUL LOW-LEVEL WIDGETS
@@ -861,7 +785,8 @@
t#vbox#set_spacing 12;
let header =
- primaryText (Format.sprintf "Connecting to '%s'..." (protect rootName)) in
+ primaryText
+ (Format.sprintf "Connecting to '%s'..." (Unicode.protect rootName)) in
let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
(* FIX: DIALOG_AUTHENTICATION is way better but is not available
@@ -869,7 +794,8 @@
ignore (GMisc.image ~stock:(*`DIALOG_AUTHENTICATION*)`DIALOG_QUESTION ~icon_size:`DIALOG
~yalign:0. ~packing:h1#pack ());
let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
- ignore(GMisc.label ~markup:(header ^ "\n\n" ^ escapeMarkup (protect msg))
+ ignore(GMisc.label ~markup:(header ^ "\n\n" ^
+ escapeMarkup (Unicode.protect msg))
~selectable:true ~yalign:0. ~packing:v1#pack ());
let passwordE = GEdit.entry ~packing:v1#pack ~visibility:false () in
@@ -1084,7 +1010,8 @@
let (profile, info) = lst#get_row_data i in
result := Some profile;
begin match info.roots with
- [r1; r2] -> root1#set_text (protect r1); root2#set_text (protect r2);
+ [r1; r2] -> root1#set_text (Unicode.protect r1);
+ root2#set_text (Unicode.protect r2);
tbl#misc#set_sensitive true
| _ -> root1#set_text ""; root2#set_text "";
tbl#misc#set_sensitive false
@@ -1370,13 +1297,15 @@
~headers_clickable:false () in
let s = Uicommon.roots2string () in
ignore (lst#append_column
- (GTree.view_column ~title:(" " ^ protect (String.sub s 0 12) ^ " ")
+ (GTree.view_column
+ ~title:(" " ^ Unicode.protect (String.sub s 0 12) ^ " ")
~renderer:(GTree.cell_renderer_text [], ["text", c_replica1]) ()));
ignore (lst#append_column
(GTree.view_column ~title:" Action "
~renderer:(GTree.cell_renderer_pixbuf [], ["pixbuf", c_action]) ()));
ignore (lst#append_column
- (GTree.view_column ~title:(" " ^ protect (String.sub s 15 12) ^ " ")
+ (GTree.view_column
+ ~title:(" " ^ Unicode.protect (String.sub s 15 12) ^ " ")
~renderer:(GTree.cell_renderer_text [], ["text", c_replica2]) ()));
ignore (lst#append_column
(GTree.view_column ~title:" Status " ()));
@@ -1404,8 +1333,9 @@
(fun i data ->
mainWindow#set_column
~title_active:false ~auto_resize:true ~title:data i)
- [| " " ^ protect (String.sub s 0 12) ^ " "; " Action ";
- " " ^ protect (String.sub s 15 12) ^ " "; " Status "; " Path" |]
+ [| " " ^ Unicode.protect (String.sub s 0 12) ^ " "; " Action ";
+ " " ^ Unicode.protect (String.sub s 15 12) ^ " "; " Status ";
+ " Path" |]
in
setMainWindowColumnHeaders();
@@ -2177,7 +2107,8 @@
let descl =
if loc1 = loc2 then "right to left" else
- Printf.sprintf "from %s to %s" (protect loc2) (protect loc1) in
+ Printf.sprintf "from %s to %s"
+ (Unicode.protect loc2) (Unicode.protect loc1) in
let right =
actionsMenu#add_image_item ~key:GdkKeysyms._less ~callback:leftAction
~image:((GMisc.image ~stock:`GO_BACK ~icon_size:`MENU ())#coerce)
Modified: trunk/src/uitext.ml
===================================================================
--- trunk/src/uitext.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/uitext.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -286,9 +286,9 @@
try
let pager = System.getenv "PAGER" in
restoreTerminal ();
- let out = Unix.open_process_out pager in
+ let out = System.open_process_out pager in
Printf.fprintf out "\n%s\n\n%s\n\n" title text;
- let _ = Unix.close_process_out out in
+ let _ = System.close_process_out out in
setupTerminal ()
with Not_found ->
Printf.printf "\n%s\n\n%s\n\n" title text)
Modified: trunk/src/unicode.ml
===================================================================
--- trunk/src/unicode.ml 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/unicode.ml 2009-05-26 09:38:19 UTC (rev 337)
@@ -865,3 +865,69 @@
end
let check_utf_8 s = scan s 0 (String.length s)
+
+(****)
+
+let wf_utf8 =
+ [[('\x01', '\x7F')];
+ [('\xC2', '\xDF'); ('\x80', '\xBF')];
+ [('\xE0', '\xE0'); ('\xA0', '\xBF'); ('\x80', '\xBF')];
+ [('\xE1', '\xEC'); ('\x80', '\xBF'); ('\x80', '\xBF')];
+ [('\xED', '\xED'); ('\x80', '\x9F'); ('\x80', '\xBF')];
+ [('\xEE', '\xEF'); ('\x80', '\xBF'); ('\x80', '\xBF')];
+ [('\xF0', '\xF0'); ('\x90', '\xBF'); ('\x80', '\xBF'); ('\x80', '\xBF')];
+ [('\xF1', '\xF3'); ('\x80', '\xBF'); ('\x80', '\xBF'); ('\x80', '\xBF')];
+ [('\xF4', '\xF4'); ('\x80', '\x8F'); ('\x80', '\xBF'); ('\x80', '\xBF')]]
+
+let rec accept_seq l s i len =
+ match l with
+ [] ->
+ Some i
+ | (a, b) :: r ->
+ if i = len || s.[i] < a || s.[i] > b then
+ None
+ else
+ accept_seq r s (i + 1) len
+
+let rec accept_rec l s i len =
+ match l with
+ [] ->
+ None
+ | seq :: r ->
+ match accept_seq seq s i len with
+ None -> accept_rec r s i len
+ | res -> res
+
+let accept = accept_rec wf_utf8
+
+(***)
+
+let protect_char buf c =
+ if c = '\x00' then
+ Buffer.add_char buf ' '
+ else if c < '\x80' then
+ Buffer.add_char buf c
+ else
+ let c = Char.code c in
+ Buffer.add_char buf (Char.chr (c lsr 6 + 0xC0));
+ Buffer.add_char buf (Char.chr (c land 0x3f + 0x80))
+
+let rec protect_rec buf s i len =
+ if i = len then
+ Buffer.contents buf
+ else
+ match accept s i len with
+ Some i' ->
+ Buffer.add_substring buf s i (i' - i);
+ protect_rec buf s i' len
+ | None ->
+ protect_char buf s.[i];
+ protect_rec buf s (i + 1) len
+
+let expl f s = f s 0 (String.length s)
+
+(* Convert a string to UTF8 by keeping all UTF8 characters unchanged
+ and considering all other characters as ISO 8859-1 characters *)
+let protect s =
+ let buf = Buffer.create (String.length s * 2) in
+ expl (protect_rec buf) s
Modified: trunk/src/unicode.mli
===================================================================
--- trunk/src/unicode.mli 2009-05-19 16:51:43 UTC (rev 336)
+++ trunk/src/unicode.mli 2009-05-26 09:38:19 UTC (rev 337)
@@ -22,3 +22,7 @@
(* Check wether the string contains only well-formed UTF-8 characters *)
val check_utf_8 : string -> bool
+
+(* Convert a string to UTF-8 by keeping all UTF-8 characters unchanged
+ and considering all other characters as ISO 8859-1 characters *)
+val protect : string -> string
More information about the Unison-hackers
mailing list