Merge pull request #10113 from xavierleroy/ocamltest-timeout

Add a `-timeout` option to ocamltest and use it in the test suite.

Changes

@@ -81,6 +81,11 @@ Working version
   changes in the parser.
   (François Pottier, review by Gabriel Scherer and Xavier Leroy.)
 
+- #10113: add a `-timeout` option to ocamltest and use it in the test suite.
+  (Xavier Leroy and Gabriel Scherer, review by Sébastien Hinderer
+   and David Allsopp)
+
+
 ### Build system:
 
 - #9191, #10091: take the LDFLAGS variable into account, except on

ocamltest/actions_helpers.ml

@@ -107,7 +107,7 @@ let run_cmd
     ?(stdout_variable=Builtin_variables.stdout)
     ?(stderr_variable=Builtin_variables.stderr)
     ?(append=false)
-    ?(timeout=0)
+    ?timeout
     log env original_cmd
   =
   let log_redirection std filename =
@@ -151,6 +151,13 @@ let run_cmd
       environment
       (Environments.to_system_env env)
   in
+  let timeout =
+    match timeout with
+    | Some timeout -> timeout
+    | None ->
+        Option.value ~default:0
+          (Environments.lookup_as_int Builtin_variables.timeout env)
+  in
   let n =
     Run_command.run {
       Run_command.progname = progname;
@@ -273,6 +280,9 @@ let run_hook hook_name log input_env =
     Builtin_variables.ocamltest_response response_file input_env in
   let systemenv =
     Environments.to_system_env hookenv in
+  let timeout =
+    Option.value ~default:0
+      (Environments.lookup_as_int Builtin_variables.timeout input_env) in
   let open Run_command in
   let settings = {
     progname = "sh";
@@ -282,7 +292,7 @@ let run_hook hook_name log input_env =
     stdout_filename = "";
     stderr_filename = "";
     append = false;
-    timeout = 0;
+    timeout = timeout;
     log = log;
   } in let exit_status = run settings in
   let final_value = match exit_status with

ocamltest/builtin_variables.ml

@@ -101,7 +101,8 @@ let test_skip = Variables.make ("TEST_SKIP",
 let test_fail = Variables.make ("TEST_FAIL",
   "Exit code to let a script report failure")
 
-
+let timeout = Variables.make ("timeout",
+  "Maximal execution time for every command (in seconds)")
 
 let _ = List.iter Variables.register_variable
   [
@@ -129,4 +130,5 @@ let _ = List.iter Variables.register_variable
     test_pass;
     test_skip;
     test_fail;
+    timeout;
   ]

ocamltest/builtin_variables.mli

@@ -65,3 +65,5 @@ val test_pass : Variables.t
 val test_skip : Variables.t
 
 val test_fail : Variables.t
+
+val timeout : Variables.t

ocamltest/environments.ml

@@ -62,6 +62,12 @@ let lookup_as_bool variable env =
   | Some "true" -> Some true
   | Some _ -> Some false
 
+let lookup_as_int variable env =
+  match lookup variable env with
+  | None -> None
+  | Some value ->
+      int_of_string_opt value
+
 let safe_lookup variable env = match lookup variable env with
   | None -> ""
   | Some value -> value

ocamltest/environments.mli

@@ -33,6 +33,11 @@ val lookup_as_bool : Variables.t -> t -> bool option
     [Some false] if it is set to another string, and
     [None] if not set. *)
 
+val lookup_as_int : Variables.t -> t -> int option
+(** returns [Some n] if the variable is set to a string
+    representation of the integer [n],
+    and [None] if it is not an integer or not set. *)
+
 val add : Variables.t -> string -> t -> t
 val add_if_undefined : Variables.t -> string -> t -> t
 val add_bindings : (Variables.t * string) list -> t -> t

ocamltest/main.ml

@@ -167,6 +167,7 @@ let test_file test_filename =
   let summary = Sys.with_chdir test_build_directory_prefix
     (fun () ->
        let promote = string_of_bool Options.promote in
+       let default_timeout = string_of_int Options.default_timeout in
        let install_hook name =
          let hook_name = Filename.make_filename hookname_prefix name in
          if Sys.file_exists hook_name then begin
@@ -187,6 +188,7 @@ let test_file test_filename =
              Builtin_variables.test_build_directory_prefix,
                test_build_directory_prefix;
              Builtin_variables.promote, promote;
+             Builtin_variables.timeout, default_timeout;
            ] in
        let rootenv =
          Environments.initialize Environments.Pre log initial_environment in

ocamltest/options.ml

@@ -49,6 +49,8 @@ let log_to_stderr = ref false
 
 let promote = ref false
 
+let default_timeout = ref 0
+
 let keep_test_dir_on_success = ref false
 
 let find_test_dirs = ref []
@@ -66,6 +68,11 @@ let commandline_options =
   ("-show-actions", Arg.Unit show_actions, " Show available actions.");
   ("-show-tests", Arg.Unit show_tests, " Show available tests.");
   ("-show-variables", Arg.Unit show_variables, " Show available variables.");
+  ("-timeout",
+     Arg.Int (fun t -> if t >= 0
+                       then default_timeout := t
+                       else raise (Arg.Bad "negative timeout")),
+     "<seconds> Set maximal execution time for every command (in seconds)");
   ("-find-test-dirs", Arg.String (add_to_list find_test_dirs),
    " Find directories that contain tests (recursive).");
   ("-list-tests", Arg.String (add_to_list list_tests),
@@ -84,6 +91,7 @@ let () =
 let log_to_stderr = !log_to_stderr
 let files_to_test = !files_to_test
 let promote = !promote
+let default_timeout = !default_timeout
 let find_test_dirs = !find_test_dirs
 let list_tests = !list_tests
 let keep_test_dir_on_success = !keep_test_dir_on_success

ocamltest/options.mli

@@ -21,6 +21,8 @@ val files_to_test : string list
 
 val promote : bool
 
+val default_timeout : int
+
 val usage : string
 
 val find_test_dirs : string list

ocamltest/run_unix.c

@@ -314,7 +314,7 @@ static int run_command_parent(const command_settings *settings, pid_t child_pid)
           if ((settings->timeout > 0) && (timeout_expired))
           {
             timeout_expired = 0;
-            fprintf(stderr, "Timeout expired, killing all child processes");
+            fprintf(stderr, "Timeout expired, killing all child processes\n");
             if (kill(-child_pid, SIGKILL) == -1) myperror("kill");
           };
           break;

ocamltest/run_win32.c

@@ -13,7 +13,10 @@
 /*                                                                        */
 /**************************************************************************/
 
-/* Run programs with rediretions and timeouts under Windows */
+/* Run programs with redirections and timeouts under Windows */
+
+/* GetTickCount64() requires Windows Vista or Server 2008 */
+#define _WIN32_WINNT 0x0600
 
 #include <stdio.h>
 #include <stdlib.h>
@@ -257,7 +260,8 @@ int run_command(const command_settings *settings)
   STARTUPINFO startup_info;
   PROCESS_INFORMATION process_info;
   BOOL wait_result;
-  DWORD status, stamp, cur;
+  DWORD status;
+  ULONGLONG stamp, cur;
   DWORD timeout = (settings->timeout > 0) ? settings->timeout * 1000 : INFINITE;
 
   JOBOBJECT_ASSOCIATE_COMPLETION_PORT port = {NULL, NULL};
@@ -359,7 +363,7 @@ int run_command(const command_settings *settings)
   ResumeThread(process_info.hThread);
   CloseHandle(process_info.hThread);
 
-  stamp = GetTickCount();
+  stamp = GetTickCount64();
   while ((wait_result = GetQueuedCompletionStatus(port.CompletionPort,
                                                   &completion_code,
                                                   &completion_key,
@@ -369,10 +373,12 @@ int run_command(const command_settings *settings)
   {
     if (timeout != INFINITE)
     {
-      cur = GetTickCount();
-      stamp = (cur > stamp ? cur - stamp : MAXDWORD - stamp + cur);
-      timeout = (timeout > stamp ? timeout - stamp : 0);
-      stamp = cur;
+      cur = GetTickCount64();
+      if (cur > stamp) {
+        ULONGLONG elapsed = cur - stamp;
+        timeout = (timeout > elapsed ? timeout - elapsed : 0);
+        stamp = cur;
+      }
     }
   }
   if (wait_result)

testsuite/Makefile

@@ -86,7 +86,10 @@ else
   OCAMLTEST_KEEP_TEST_DIR_ON_SUCCESS_FLAG := -keep-test-dir-on-success
 endif
 
+TIMEOUT ?= 600 # 10 minutes
+
 OCAMLTESTFLAGS := \
+  -timeout $(TIMEOUT) \
   $(OCAMLTEST_PROMOTE_FLAG) \
   $(OCAMLTEST_KEEP_TEST_DIR_ON_SUCCESS_FLAG)