diff --git a/TODO.org b/TODO.org index c5a6fd76..1c6386bb 100644 --- a/TODO.org +++ b/TODO.org @@ -1708,7 +1708,8 @@ flake and a flake is how a watchdog gets deleted. ** DONE A test binary leaves nothing in the temporary directory it was given CLOSED: [2026-09-25] -Every test binary makes =flan-t= under its =TMPDIR=, exports it as +Every test binary makes a fresh =flan-t-= under its =TMPDIR=, never +adopting an existing entry, exports it as =TMPDIR= to everything it starts, and removes it on exit, on the watchdog, and on SIGINT or SIGTERM (=test/own_tmp.ml=). A binary exits nonzero if that directory survives or if a =flan-= or =flan-dev-= for its own pid diff --git a/test/own_tmp.ml b/test/own_tmp.ml index a3f2453b..c9ec7963 100644 --- a/test/own_tmp.ml +++ b/test/own_tmp.ml @@ -37,11 +37,25 @@ let owner = Unix.getpid () (* Short, because a Unix socket path has 108 bytes and the sockets the tests bind are under here: [flan-dev-/agent.sock], and names such as - [flan-devtest-halfwrite--llvm.sock]. *) + [flan-devtest-halfwrite--llvm.sock]. + + Made fresh, never adopted: [mkdir] fails on any existing entry, a symlink + included, and a name that is taken is passed over for another. So the + directory this binary removes at exit is one it provably created, and + nothing someone else put at that name is followed or deleted. *) let dir = - let d = Filename.concat outer (Printf.sprintf "flan-t%d" owner) in - (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); - d + Random.self_init (); + let rec make tries = + let d = + Filename.concat outer + (Printf.sprintf "flan-t%d-%04x" owner (Random.bits () land 0xffff)) + in + match Unix.mkdir d 0o700 with + | () -> d + | exception Unix.Unix_error (Unix.EEXIST, _, _) when tries > 0 -> + make (tries - 1) + in + make 100 let () = Unix.putenv "TMPDIR" dir; @@ -61,13 +75,19 @@ let rec remove path = if removing it failed, and a session or build directory named for this process in the directory it was given. The second is an in-process session or build that did not go through [dir] — something that read the temporary - directory before this module set it. *) + directory before this module set it. A name already there when this binary + started belongs to an earlier process that had the same pid, and is not + counted. *) +let named_for_me = + [ Filename.concat outer (Printf.sprintf "flan-dev-%d" owner); + Filename.concat outer (Printf.sprintf "flan-%d" owner) ] + +let already = List.filter Sys.file_exists named_for_me + let leftovers () = - let mine = - [ Filename.concat outer (Printf.sprintf "flan-dev-%d" owner); - Filename.concat outer (Printf.sprintf "flan-%d" owner) ] - in - List.filter Sys.file_exists (dir :: mine) + List.filter + (fun d -> Sys.file_exists d && not (List.mem d already)) + (dir :: named_for_me) (* Only the process that made the directory removes it. The binaries fork (test_acceptance's compile pool, the daemons before they exec), and a