From b787de04da85da2f911c8248e07342e58b4e8625 Mon Sep 17 00:00:00 2001 From: Tõivo Leedjärv Date: Fre, 24 Mar 2023 17:22:09 +0100 Subject: [PATCH] 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/fswatchold.ml | 25 +++-- src/remote.ml | 3 +- src/system/system_generic.ml | 204 +++++++++++++++++++++++++++++++++++ src/uitext.ml | 1 - 6 files changed, 326 insertions(+), 14 deletions(-) index 17f22dcb..13cab93b 100644 --- fswatchold.ml +++ fswatchold.ml @@ -116,19 +116,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 diff --git a/src/remote.ml b/src/remote.ml index d320470a..0ed393ae 100644 --- remote.ml +++ 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) diff --git a/src/system/system_generic.ml b/src/system/system_generic.ml index 2147d44d..3ef4fb09 100644 --- system/system_generic.ml +++ system/system_generic.ml @@ -15,6 +15,210 @@ along with this program. If not, see . *) +(* 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 diff --git a/src/uitext.ml b/src/uitext.ml index 1c2e509d..fbb4f7f1 100644 --- uitext.ml +++ uitext.ml @@ -1621,7 +1621,6 @@ and breakRepeat = function | Assert_failure _ | Match_failure _ | Invalid_argument _ - | Fun.Finally_raised _ (* Async exceptions *) | Out_of_memory | Stack_overflow -- 2.39.2