diff --git a/CHANGES.md b/CHANGES.md index cd72f0adec..97210961bd 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -15,6 +15,8 @@ unreleased - Correctly traverse patterns when looking for docs in the typedtree (#1572) - Get documentation when the declaration or definition is selected (#1542, fixes #1540) + - On Windows, change to a harmless directory when launching server to avoid + locking down current directory. (#1569, fixes #1474) + test suite - Add multiple tests for locate over ill-typed expressions (#1546) diff --git a/src/frontend/ocamlmerlin/new/new_merlin.ml b/src/frontend/ocamlmerlin/new/new_merlin.ml index 8770a39f21..ef16dbca8b 100644 --- a/src/frontend/ocamlmerlin/new/new_merlin.ml +++ b/src/frontend/ocamlmerlin/new/new_merlin.ml @@ -147,21 +147,30 @@ let run = function prerr_endline ("Exception: " ^ Printexc.to_string exn); 1 +let with_wd ~wd ~old_wd f args = + match Sys.chdir wd with + | () -> + log ~title:"run" "changed directory to %S (old wd: %S)" wd old_wd; + Fun.protect ~finally:(fun () -> Sys.chdir old_wd) (fun () -> f args) + | exception Sys_error _ -> + log ~title:"run" "cannot change working directory to %S (old wd: %S)" + wd old_wd; + f args + let run ~new_env wd args = begin match new_env with | Some env -> Os_ipc.merlin_set_environ env; Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ())) | None -> () end; - let wd_msg = match wd with - | None -> "No working directory specified" - | Some wd -> - try Sys.chdir wd; Printf.sprintf "changed directory to %S" wd - with _ -> Printf.sprintf "cannot change working directory to %S" wd + let old_wd = Sys.getcwd () in + let run args () = match wd with + | Some wd -> with_wd ~wd ~old_wd run args + | None -> + log ~title:"run" "No working directory specified (old wd: %S)" old_wd; + run args in let `Log_file_path log_file, `Log_sections sections = Log_info.get () in - Logger.with_log_file log_file ~sections @@ fun () -> - log ~title:"run" "%s" wd_msg; - run args + Logger.with_log_file log_file ~sections @@ run args diff --git a/src/frontend/ocamlmerlin/ocamlmerlin.c b/src/frontend/ocamlmerlin/ocamlmerlin.c index 6e7ce9a2dc..f87a5b2f37 100644 --- a/src/frontend/ocamlmerlin/ocamlmerlin.c +++ b/src/frontend/ocamlmerlin/ocamlmerlin.c @@ -279,7 +279,7 @@ static int connect_socket(const char *socketname, int fail) #ifdef _WIN32 static void start_server(const char *socketname, const char* eventname, const char *exec_path) { - char buf[PATHSZ]; + char buf[PATHSZ], lpSystemDir[PATHSZ]; PROCESS_INFORMATION pi; STARTUPINFO si; HANDLE hEvent = CreateEvent(NULL, FALSE, FALSE, eventname); @@ -288,9 +288,12 @@ static void start_server(const char *socketname, const char* eventname, const ch ZeroMemory(&si, sizeof(si)); si.cb = sizeof(si); ZeroMemory(&pi, sizeof(pi)); + /* Change to a harmless directory, so that process still works if the current + directory is deleted. */ + GetSystemDirectory(lpSystemDir, PATHSZ); /* Note that DETACHED_PROCESS means that the process does not appear in Task Manager but the server can still be stopped with ocamlmerlin server stop-server */ - if (!CreateProcess(exec_path, buf, NULL, NULL, FALSE, DETACHED_PROCESS, NULL, NULL, &si, &pi)) + if (!CreateProcess(exec_path, buf, NULL, NULL, FALSE, DETACHED_PROCESS, NULL, lpSystemDir, &si, &pi)) failwith_perror("fork"); CloseHandle(pi.hProcess); CloseHandle(pi.hThread); diff --git a/tests/test-dirs/server-tests/chdir_to_root.t b/tests/test-dirs/server-tests/chdir_to_root.t new file mode 100644 index 0000000000..d3d2ee521c --- /dev/null +++ b/tests/test-dirs/server-tests/chdir_to_root.t @@ -0,0 +1,13 @@ +In case server is running, stop it. + + $ $MERLIN server stop-server + +Check that the working directory of the server process is correctly restored. + + $ touch test.ml + $ export MERLIN_LOG=- + $ $MERLIN server errors -filename test.ml < test.ml 2>&1 | grep 'old wd' + changed directory to "$TESTCASE_ROOT" (old wd: "/") + $ $MERLIN server errors -filename test.ml < test.ml 2>&1 | grep 'old wd' + changed directory to "$TESTCASE_ROOT" (old wd: "/") + $ $MERLIN server stop-server diff --git a/tests/test-dirs/server-tests/dune b/tests/test-dirs/server-tests/dune index 3b649e9854..58f1b6f2c9 100644 --- a/tests/test-dirs/server-tests/dune +++ b/tests/test-dirs/server-tests/dune @@ -3,3 +3,8 @@ (applies_to :whole_subtree) (alias all-server-tests) (locks merlin_server)) + +(cram + (applies_to chdir_to_root) + (enabled_if + (<> %{os_type} Win32)))