From ed5b56f21240dffa265066197ee7e81fcb0c7a50 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 14:05:29 +0700 Subject: [PATCH] A daemon under a test harness ends within a second or two of the harness going even while a client holds its connection. --- lib/dev.ml | 74 ++++++++++++++++++++++++++++++++------------- test/test_dev.ml | 79 +++++++++++++++++++++++++++++------------------- 2 files changed, 101 insertions(+), 52 deletions(-) diff --git a/lib/dev.ml b/lib/dev.ml index 1157eccd..6897d2a8 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -5106,6 +5106,27 @@ let push_request p req op reply = else p.watch_every <- None | _ -> () +(* A test harness that starts a daemon names itself in FLAN_DEV_HARNESS + (test/watchdog.ml), and the daemon dies with its parent and ends when the + harness has gone. The parent half is PR_SET_PDEATHSIG, armed in [start]. + The harness half is for a daemon whose parent is not the harness — one an + Emacs under test started — and is read by [accept_loop] and [serve]. + Opt-in only: a daemon an editor or a shell starts must outlive them, as it + always has. *) +let harness () = + match Sys.getenv_opt "FLAN_DEV_HARNESS" with + | Some s -> + (match int_of_string_opt (String.trim s) with + | Some p when p > 0 -> Some p + | _ -> None) + | None -> None + +let alive pid = + match Unix.kill pid 0 with + | () -> true + | exception Unix.Unix_error (Unix.ESRCH, _, _) -> false + | exception Unix.Unix_error _ -> true + (* ── The loop ──────────────────────────────────────────────────────── *) (* One connection at a time. An editor is one client, evaluations are @@ -5118,12 +5139,43 @@ let push_request p req op reply = let serve t fd = let p = { on = false; out_due = None; last_out = 0.; watch_every = None; watch_due = 0.; pend = Buffer.create 4096; sent = 0 } in + (* Under a test harness only: an attached client is no proof the harness is + alive — an Emacs under test holds its connection after the test binary + that ran it is gone, and it is this daemon's parent, so PDEATHSIG does not + fire either. So the wait is capped at a second and the harness looked at + each time round. Not the socket: an attached editor can still reach this + daemon whatever happened to the file. *) + let harness_pid = harness () in + let harness_due = ref 0. in + let harness_gone () = + match harness_pid with + | None -> false + | Some pid -> + let now = Unix.gettimeofday () in + if now < !harness_due then false + else begin + harness_due := now +. 1.; + if alive pid then false + else begin + Printf.eprintf + "flan dev: this session is ending; the test harness that started \ + it (pid %d) has exited\n%!" pid; + true + end + end + in + let cap wait = + match harness_pid with + | None -> wait + | Some _ -> if wait < 0. || wait > 1. then 1. else wait + in (* Between requests: push what is due, then wait for a request, for the program's output, or for the next push, whichever comes first. The pipe is drained here whether or not this client takes pushes, which is the liveness requirement [drain] describes, met while an editor is attached as well as between editors. *) let rec go () = + if harness_gone () then true else match push_due p t fd (Unix.gettimeofday ()) with | exception Unix.Unix_error _ -> false | blocked -> @@ -5134,7 +5186,7 @@ let serve t fd = let wfds, wait = if blocked then [ fd ], -1. else [], push_wait p (Unix.gettimeofday ()) in - (match Unix.select fds wfds [] wait with + (match Unix.select fds wfds [] (cap wait) with | ready, _, _ -> if List.mem t.stdout ready && not t.finished then begin drain t; @@ -5314,26 +5366,6 @@ let still_bound b = | s -> s.Unix.st_dev = b.dev && s.Unix.st_ino = b.ino | exception Unix.Unix_error _ -> false -(* A test harness that starts a daemon names itself in FLAN_DEV_HARNESS - (test/watchdog.ml), and the daemon dies with its parent and ends when the - harness has gone. The parent half is PR_SET_PDEATHSIG, armed in [start]. - The harness half is for a daemon whose parent is not the harness — one an - Emacs under test started — and is read by [accept_loop]. Opt-in only: a - daemon an editor or a shell starts must outlive them, as it always has. *) -let harness () = - match Sys.getenv_opt "FLAN_DEV_HARNESS" with - | Some s -> - (match int_of_string_opt (String.trim s) with - | Some p when p > 0 -> Some p - | _ -> None) - | None -> None - -let alive pid = - match Unix.kill pid 0 with - | () -> true - | exception Unix.Unix_error (Unix.ESRCH, _, _) -> false - | exception Unix.Unix_error _ -> true - (* Why the session can no longer be reached, if it cannot. *) let unreachable bound = match bound with diff --git a/test/test_dev.ml b/test/test_dev.ml index b856d62e..268a9149 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -6045,37 +6045,54 @@ let () = kids); (try Sys.remove ksock with Sys_error _ -> ()); - (* The harness gone, the parent alive. [sleep] stands in for it. *) - let hsock = tmp "orphan-harness.sock" in - (try Sys.remove hsock with Sys_error _ -> ()); - let stand_in = - Unix.create_process "sleep" [| "sleep"; "600" |] Unix.stdin - Unix.stdout Unix.stderr - in - let d = - Unix.create_process_env flan (argv hsock) - (with_harness [ "FLAN_DEV_HARNESS=" ^ string_of_int stand_in ]) - Unix.stdin Unix.stdout Unix.stderr - in - if not (listening ~pid:d hsock) then - fail "a daemon with a harness (%s): %s" shape !listen_why - else begin - Unix.kill stand_in Sys.sigkill; - ignore (Unix.waitpid [] stand_in); - let ended = - await ~ms:5000 (fun () -> - match Unix.waitpid [ Unix.WNOHANG ] d with - | 0, _ -> false - | _ -> true) - in - if not ended then - fail "a daemon (%s) outlived the test harness that started it" shape - end; - (try Unix.kill stand_in Sys.sigkill with Unix.Unix_error _ -> ()); - (try Unix.kill d Sys.sigkill with Unix.Unix_error _ -> ()); - (try ignore (Unix.waitpid [] d) with Unix.Unix_error _ -> ()); - (try ignore (Unix.waitpid [] stand_in) with Unix.Unix_error _ -> ()); - (try Sys.remove hsock with Sys_error _ -> ()); + (* The harness gone, the parent alive. [sleep] stands in for it. + Twice: with no client, and with one connected and holding on, as + an Emacs under test does after the binary that ran it is gone. *) + List.iter + (fun held -> + let how = if held then "connected" else "idle" in + let hsock = tmp "orphan-harness.sock" in + (try Sys.remove hsock with Sys_error _ -> ()); + let stand_in = + Unix.create_process "sleep" [| "sleep"; "600" |] Unix.stdin + Unix.stdout Unix.stderr + in + let d = + Unix.create_process_env flan (argv hsock) + (with_harness [ "FLAN_DEV_HARNESS=" ^ string_of_int stand_in ]) + Unix.stdin Unix.stdout Unix.stderr + in + let client = ref None in + if not (listening ~pid:d hsock) then + fail "a daemon with a harness (%s, %s): %s" shape how !listen_why + else begin + if held then begin + let c = connect hsock in + client := Some c; + if status (request c "(:op \"describe\")") <> "ok" then + fail "a daemon with a harness (%s): describe failed" shape + end; + Unix.kill stand_in Sys.sigkill; + ignore (Unix.waitpid [] stand_in); + let ended = + await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] d with + | 0, _ -> false + | _ -> true) + in + if not ended then + fail "a daemon (%s, %s) outlived the test harness that \ + started it" shape how + end; + (match !client with + | Some c -> (try Unix.close c with Unix.Unix_error _ -> ()) + | None -> ()); + (try Unix.kill stand_in Sys.sigkill with Unix.Unix_error _ -> ()); + (try Unix.kill d Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] d) with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] stand_in) with Unix.Unix_error _ -> ()); + (try Sys.remove hsock with Sys_error _ -> ())) + [ false; true ]; (* The socket: kept, the daemon stays; deleted, it ends, cleanly. *) let ssock = tmp "orphan-socket.sock" in