Restore compatibility with OCaml 4.06 and 4.07 (temporary patch)

This patch should not break compilation with OCaml 4.x but it is
recommended to drop the patch for OCaml > 4.07.

It will break compilation with OCaml >= 5.0 (due to the change in
Makefile.OCaml).

src/Makefile.OCaml

@@ -248,7 +248,7 @@ OCAMLOBJS+=main.cmo
 
 # OCaml libraries for the bytecode version
 # File extensions will be substituted for the native code version
-OCAMLLIBS+=unix.cma str.cma
+OCAMLLIBS+=unix.cma str.cma bigarray.cma
 INCLFLAGS+=-I +unix -I +str
 
 COBJS+=osxsupport$(OBJ_EXT) pty$(OBJ_EXT) bytearray_stubs$(OBJ_EXT) hash_compat$(OBJ_EXT) props_xattr$(OBJ_EXT) props_acl$(OBJ_EXT)

src/fswatchold.ml

@@ -113,19 +113,22 @@ let readChanges wi =
 let watcherRunning archHash =
   RootMap.mem archHash !watchers &&
     let wi = RootMap.find archHash !watchers in
+    let cleanup () =
+      watchers := RootMap.remove archHash !watchers;
+      begin
+        try ignore (System.close_process_out wi.proc)
+        with Unix.Unix_error _ -> ()
+      end;
+      begin match wi.ch with
+      | Some ch -> close_in_noerr ch
+      | None -> ()
+      end;
+      false
+    in
     match Unix.waitpid [Unix.WNOHANG] (System.process_out_pid wi.proc) with
+    | exception Unix.Unix_error (ECHILD, _, _) -> cleanup ()
     | (0, _) -> true
-    | _ | exception Unix.Unix_error (ECHILD, _, _) ->
-        watchers := RootMap.remove archHash !watchers;
-        begin
-          try ignore (System.close_process_out wi.proc)
-          with Unix.Unix_error _ -> ()
-        end;
-        begin match wi.ch with
-        | Some ch -> close_in_noerr ch
-        | None -> ()
-        end;
-        false
+    | _ -> cleanup ()
 
 let getChanges archHash =
   if StringSet.mem archHash !newWatchers then

src/remote.ml

@@ -1887,11 +1887,12 @@ let buildShellConnection shell host userOpt portOpt rootName termInteract =
           let kill_noerr si = try Unix.kill pid si
             with Unix.Unix_error _ -> () | Invalid_argument _ -> () in
           match Unix.waitpid [WNOHANG] pid with
+          | exception Unix.Unix_error _ -> ()
           | (0, _) ->
               (* Grace period before killing. Important to give ssh a chance
                  to restore terminal settings, should that be needed. *)
               kill_noerr Sys.sigterm; Unix.sleepf 0.01; kill_noerr Sys.sigkill
-          | _ | exception Unix.Unix_error _ -> ()
+          | _ -> ()
         in
         let () = at_exit end_ssh in
         (None, pid)

src/system/system_generic.ml

@@ -15,6 +15,210 @@
     along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)
 
+(* OCaml 4.07 compatibility ONLY *)
+module Unix = struct
+
+include Unix
+
+(* The following code is taken from OCaml sources.
+   Authors of code snippets: Xavier Leroy, Damien Doligez and Romain Beauxis *)
+
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+external dumpFd : Unix.file_descr -> int = "%identity"
+
+external sys_exit : int -> 'a = "caml_sys_exit"
+
+let rec waitpid_non_intr pid =
+  try waitpid [] pid
+  with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
+
+(* Duplicate [fd] if needed to make sure it isn't one of the
+   standard descriptors (stdin, stdout, stderr).
+   Note that this function always leaves the standard descriptors open,
+   the caller must take care of closing them if needed.
+   The "cloexec" mode doesn't matter, because
+   the descriptor returned by [dup] will be closed before the [exec],
+   and because no other thread is running concurrently
+   (we are in the child process of a fork).
+ *)
+let rec file_descr_not_standard fd =
+  if dumpFd fd >= 3 then fd else file_descr_not_standard (dup fd)
+
+let safe_close fd =
+  try close fd with Unix_error(_,_,_) -> ()
+
+let perform_redirections new_stdin new_stdout new_stderr =
+  let new_stdin = file_descr_not_standard new_stdin in
+  let new_stdout = file_descr_not_standard new_stdout in
+  let new_stderr = file_descr_not_standard new_stderr in
+  (*  The three dup2 close the original stdin, stdout, stderr,
+      which are the descriptors possibly left open
+      by file_descr_not_standard *)
+  dup2 ~cloexec:false new_stdin stdin;
+  dup2 ~cloexec:false new_stdout stdout;
+  dup2 ~cloexec:false new_stderr stderr;
+  safe_close new_stdin;
+  safe_close new_stdout;
+  safe_close new_stderr
+
+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 envopt proc input output error =
+   match fork() with
+     0 -> perform_redirections input output error;
+          let shell = "/bin/sh" in
+          let argv = [| shell; "-c"; cmd |] in
+          begin try
+            match envopt with
+            | Some env -> execve shell argv env
+            | None     -> execv shell argv
+          with _ ->
+            sys_exit 127
+          end
+   | id -> Hashtbl.add popen_processes proc id
+
+let open_process_in cmd =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let inchan = in_channel_of_descr in_read in
+  begin
+    try
+      open_proc cmd None (Process_in inchan) stdin in_write stderr
+    with e ->
+      close_in inchan;
+      close in_write;
+      raise e
+  end;
+  close in_write;
+  inchan
+
+let open_process_out cmd =
+  let (out_read, out_write) = pipe ~cloexec:true () in
+  let outchan = out_channel_of_descr out_write in
+  begin
+    try
+      open_proc cmd None (Process_out outchan) out_read stdout stderr
+    with e ->
+    close_out outchan;
+    close out_read;
+    raise e
+  end;
+  close out_read;
+  outchan
+
+let open_process cmd =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let (out_read, out_write) =
+    try pipe ~cloexec:true ()
+    with e -> close in_read; close in_write; raise e in
+  let inchan = in_channel_of_descr in_read in
+  let outchan = out_channel_of_descr out_write in
+  begin
+    try
+      open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr
+    with e ->
+      close out_read; close out_write;
+      close in_read; close in_write;
+      raise e
+  end;
+  close out_read;
+  close in_write;
+  (inchan, outchan)
+
+let open_process_full cmd env =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let (out_read, out_write) =
+    try pipe ~cloexec:true ()
+    with e -> close in_read; close in_write; raise e in
+  let (err_read, err_write) =
+    try pipe ~cloexec:true ()
+    with e -> close in_read; close in_write;
+              close out_read; close out_write; raise e in
+  let inchan = in_channel_of_descr in_read in
+  let outchan = out_channel_of_descr out_write in
+  let errchan = in_channel_of_descr err_read in
+  begin
+    try
+      open_proc cmd (Some env) (Process_full(inchan, outchan, errchan))
+                out_read in_write err_write
+    with e ->
+      close out_read; close out_write;
+      close in_read; close in_write;
+      close err_read; close err_write; 
+      raise e
+  end;
+  close out_read;
+  close in_write;
+  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_error(EBADF, fun_name, ""))
+
+let close_process_in inchan =
+  let pid = find_proc_id "close_process_in" (Process_in inchan) in
+  close_in inchan;
+  snd(waitpid_non_intr pid)
+
+let close_process_out outchan =
+  let pid = find_proc_id "close_process_out" (Process_out outchan) in
+  (* The application may have closed [outchan] already to signal
+     end-of-input to the process.  *)
+  begin try close_out outchan with Sys_error _ -> () end;
+  snd(waitpid_non_intr pid)
+
+let close_process (inchan, outchan) =
+  let pid = find_proc_id "close_process" (Process(inchan, outchan)) in
+  close_in inchan;
+  begin try close_out outchan with Sys_error _ -> () end;
+  snd(waitpid_non_intr 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;
+  begin try close_out outchan with Sys_error _ -> () end;
+  close_in errchan;
+  snd(waitpid_non_intr pid)
+
+let process_in_pid inchan =
+  find_proc_id "process_in_pid" (Process_in inchan)
+let process_out_pid outchan =
+  find_proc_id "process_out_pid" (Process_out outchan)
+let process_pid (inchan, outchan) =
+  find_proc_id "process_pid" (Process(inchan, outchan))
+let process_full_pid (inchan, outchan, errchan) =
+  find_proc_id "process_full_pid"
+    (Process_full(inchan, outchan, errchan))
+
+end
+(* / *)
+
 type fspath = string
 
 let mfspath = Umarshal.string

src/ubase/umarshal.ml

@@ -15,6 +15,111 @@
     along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)
 
+(* OCaml 4.07 compatibility ONLY *)
+module Bytes = struct
+
+include Bytes
+
+(* The following code is taken from OCaml sources.
+   Authors of the code snippet: Alain Frisch and Daniel Bünzli *)
+
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {6 Binary encoding/decoding of integers} *)
+
+external get_uint8 : bytes -> int -> int = "%string_safe_get"
+external get_uint16_ne : bytes -> int -> int = "%caml_string_get16"
+external get_int32_ne : bytes -> int -> int32 = "%caml_string_get32"
+external get_int64_ne : bytes -> int -> int64 = "%caml_string_get64"
+external set_int8 : bytes -> int -> int -> unit = "%string_safe_set"
+external set_int16_ne : bytes -> int -> int -> unit = "%caml_string_set16"
+external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_string_set32"
+external set_int64_ne : bytes -> int -> int64 -> unit = "%caml_string_set64"
+external swap16 : int -> int = "%bswap16"
+external swap32 : int32 -> int32 = "%bswap_int32"
+external swap64 : int64 -> int64 = "%bswap_int64"
+
+let get_int8 b i =
+  ((get_uint8 b i) lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)
+
+let get_uint16_le b i =
+  if Sys.big_endian then swap16 (get_uint16_ne b i)
+  else get_uint16_ne b i
+
+let get_uint16_be b i =
+  if not Sys.big_endian then swap16 (get_uint16_ne b i)
+  else get_uint16_ne b i
+
+let get_int16_ne b i =
+  ((get_uint16_ne b i) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
+
+let get_int16_le b i =
+  ((get_uint16_le b i) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
+
+let get_int16_be b i =
+  ((get_uint16_be b i) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
+
+let get_int32_le b i =
+  if Sys.big_endian then swap32 (get_int32_ne b i)
+  else get_int32_ne b i
+
+let get_int32_be b i =
+  if not Sys.big_endian then swap32 (get_int32_ne b i)
+  else get_int32_ne b i
+
+let get_int64_le b i =
+  if Sys.big_endian then swap64 (get_int64_ne b i)
+  else get_int64_ne b i
+
+let get_int64_be b i =
+  if not Sys.big_endian then swap64 (get_int64_ne b i)
+  else get_int64_ne b i
+
+let set_int16_le b i x =
+  if Sys.big_endian then set_int16_ne b i (swap16 x)
+  else set_int16_ne b i x
+
+let set_int16_be b i x =
+  if not Sys.big_endian then set_int16_ne b i (swap16 x)
+  else set_int16_ne b i x
+
+let set_int32_le b i x =
+  if Sys.big_endian then set_int32_ne b i (swap32 x)
+  else set_int32_ne b i x
+
+let set_int32_be b i x =
+  if not Sys.big_endian then set_int32_ne b i (swap32 x)
+  else set_int32_ne b i x
+
+let set_int64_le b i x =
+  if Sys.big_endian then set_int64_ne b i (swap64 x)
+  else set_int64_ne b i x
+
+let set_int64_be b i x =
+  if not Sys.big_endian then set_int64_ne b i (swap64 x)
+  else set_int64_ne b i x
+
+let set_uint8 = set_int8
+let set_uint16_ne = set_int16_ne
+let set_uint16_be = set_int16_be
+let set_uint16_le = set_int16_le
+
+end
+(* / *)
+
 exception Error of string
 
 type 'a t = {