diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 3532b09b..358c0836 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -88,24 +88,61 @@ let make_test_env () = bind "try-call" (fun args -> match args with | [thunk] -> - (try - (* Call the thunk: it's a lambda with no params *) - let result = eval_expr (List [thunk]) (Env env) in - ignore result; - let d = Hashtbl.create 2 in - Hashtbl.replace d "ok" (Bool true); - Dict d - with - | Eval_error msg -> - let d = Hashtbl.create 2 in - Hashtbl.replace d "ok" (Bool false); - Hashtbl.replace d "error" (String msg); - Dict d - | exn -> - let d = Hashtbl.create 2 in - Hashtbl.replace d "ok" (Bool false); - Hashtbl.replace d "error" (String (Printexc.to_string exn)); - Dict d) + (* Fork-based timeout: child runs test, parent waits up to 5s *) + let r, w = Unix.pipe () in + let pid = Unix.fork () in + if pid = 0 then begin + (* Child process *) + Unix.close r; + let write_result s = + let _ = Unix.write_substring w s 0 (String.length s) in + Unix.close w; exit 0 in + (try + let result = eval_expr (List [thunk]) (Env env) in + ignore result; + write_result "OK:" + with + | Eval_error msg -> write_result ("ERR:" ^ msg) + | exn -> write_result ("EXN:" ^ Printexc.to_string exn)) + end else begin + (* Parent process *) + Unix.close w; + (* Wait with timeout using select *) + let deadline = Unix.gettimeofday () +. 5.0 in + let rec wait_loop () = + let remaining = deadline -. Unix.gettimeofday () in + if remaining <= 0.0 then begin + Unix.kill pid Sys.sigkill; + ignore (Unix.waitpid [] pid); + Unix.close r; + let d = Hashtbl.create 2 in + Hashtbl.replace d "ok" (Bool false); + Hashtbl.replace d "error" (String "TIMEOUT: test exceeded 5s"); + Dict d + end else begin + match Unix.select [r] [] [] (min remaining 0.1) with + | _ :: _, _, _ -> + let buf = Bytes.create 4096 in + let n = Unix.read r buf 0 4096 in + Unix.close r; + ignore (Unix.waitpid [] pid); + let msg = Bytes.sub_string buf 0 n in + if String.length msg >= 3 && String.sub msg 0 3 = "OK:" then begin + let d = Hashtbl.create 2 in + Hashtbl.replace d "ok" (Bool true); + Dict d + end else begin + let err = if String.length msg > 4 then String.sub msg 4 (String.length msg - 4) else msg in + let d = Hashtbl.create 2 in + Hashtbl.replace d "ok" (Bool false); + Hashtbl.replace d "error" (String err); + Dict d + end + | [], _, _ -> wait_loop () + end + in + wait_loop () + end | _ -> raise (Eval_error "try-call: expected 1 arg")); bind "report-pass" (fun args -> @@ -1555,7 +1592,63 @@ let run_spec_tests env test_files = let el = match Hashtbl.find_opt d "__mock_el" with Some (Dict e) -> e | _ -> d in Number (float_of_int (List.length (get_classes el))) else - (match Hashtbl.find_opt d key with Some v -> v | None -> Nil) + (match Hashtbl.find_opt d key with + | Some v -> v + | None -> + (* For mock elements, return a truthy sentinel for method names + so that guards like (host-get el "setAttribute") pass *) + if mt = "element" then + (match key with + | "setAttribute" | "getAttribute" | "removeAttribute" | "hasAttribute" + | "addEventListener" | "removeEventListener" | "dispatchEvent" + | "appendChild" | "removeChild" | "insertBefore" | "replaceChild" + | "querySelector" | "querySelectorAll" | "closest" | "matches" + | "contains" | "cloneNode" | "remove" | "focus" | "blur" | "click" + | "insertAdjacentHTML" | "prepend" | "showModal" | "show" | "close" + | "getBoundingClientRect" | "getAnimations" | "scrollIntoView" + | "scrollTo" | "scroll" -> Bool true + | "firstElementChild" -> + let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in + (match kids with c :: _ -> c | [] -> Nil) + | "lastElementChild" -> + let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in + (match List.rev kids with c :: _ -> c | [] -> Nil) + | "nextElementSibling" -> + (match Hashtbl.find_opt d "parentElement" with + | Some (Dict p) -> + let kids = match Hashtbl.find_opt p "children" with Some (List l) -> l | _ -> [] in + let rec find_next = function + | [] | [_] -> Nil + | a :: b :: _ when a == Dict d -> b + | _ :: rest -> find_next rest in + find_next kids + | _ -> Nil) + | "previousElementSibling" -> + (match Hashtbl.find_opt d "parentElement" with + | Some (Dict p) -> + let kids = match Hashtbl.find_opt p "children" with Some (List l) -> l | _ -> [] in + let rec find_prev prev = function + | [] -> Nil + | a :: _ when a == Dict d -> prev + | a :: rest -> find_prev a rest in + find_prev Nil kids + | _ -> Nil) + | "ownerDocument" -> mock_document + | _ -> Nil) + else if mt = "document" then + (match key with + | "createElement" | "createElementNS" | "createDocumentFragment" + | "createTextNode" | "createComment" | "getElementById" + | "querySelector" | "querySelectorAll" | "createEvent" + | "addEventListener" | "removeEventListener" -> Bool true + | "head" -> + let head = Hashtbl.create 4 in + Hashtbl.replace head "__mock_type" (String "element"); + Hashtbl.replace head "tagName" (String "HEAD"); + Dict head + | "activeElement" -> Nil + | _ -> Nil) + else Nil) | [Dict d; Number n] -> (* Array index access *) let i = int_of_float n in diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index a699b921..66cf5915 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -8,7 +8,16 @@ open Sx_runtime (* Trampoline — forward ref, resolved after eval_expr is defined. *) let trampoline_fn : (value -> value) ref = ref (fun v -> v) -let trampoline v = !trampoline_fn v +(* Step limit for detecting infinite loops — 0 = unlimited *) +let step_limit : int ref = ref 0 +let step_count : int ref = ref 0 +let trampoline v = + if !step_limit > 0 then begin + incr step_count; + if !step_count > !step_limit then + raise (Sx_types.Eval_error "TIMEOUT: step limit exceeded") + end; + !trampoline_fn v