1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Sebastien Hinderer, projet Gallium, INRIA Paris *)
6 (* *)
7 (* Copyright 2016 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* Main program of the ocamltest test driver *)
17
18 open Ocamltest_stdlib
19 open Tsl_semantics
20
21 type behavior =
22 | Skip_all_tests
23 | Run of Environments.t
24
25 (*
26 let first_token filename =
27 let input_channel = open_in filename in
28 let lexbuf = Lexing.from_channel input_channel in
29 Location.init lexbuf filename;
30 let token =
31 try Tsl_lexer.token lexbuf with e -> close_in input_channel; raise e
32 in close_in input_channel; token
33
34 let is_test filename =
35 match first_token filename with
36 | exception _ -> false
37 | Tsl_parser.TSL_BEGIN_C_STYLE | TSL_BEGIN_OCAML_STYLE -> true
38 | _ -> false
39 *)
40
41 (* this primitive announce should be used for tests
42 that were aborted on system error before ocamltest
43 could parse them *)
44 let announce_test_error test_filename error =
45 Printf.printf " ... testing '%s' => unexpected error (%s)\n%!"
46 (Filename.basename test_filename) error
47
48 let tsl_block_of_file test_filename =
49 let input_channel = open_in test_filename in
50 let lexbuf = Lexing.from_channel input_channel in
51 Location.init lexbuf test_filename;
52 match Tsl_parser.tsl_block Tsl_lexer.token lexbuf with
53 | exception e -> close_in input_channel; raise e
54 | _ as tsl_block -> close_in input_channel; tsl_block
55
56 let tsl_block_of_file_safe test_filename =
57 try tsl_block_of_file test_filename with
58 | Sys_error message ->
59 Printf.eprintf "%s\n%!" message;
60 announce_test_error test_filename message;
61 exit 1
62 | Parsing.Parse_error ->
63 Printf.eprintf "Could not read test block in %s\n%!" test_filename;
64 announce_test_error test_filename "could not read test block";
65 exit 1
66
67 let print_usage () =
68 Printf.printf "%s\n%!" Options.usage
69
70 let rec run_test log common_prefix path behavior = function
71 Node (testenvspec, test, env_modifiers, subtrees) ->
72 Printf.printf "%s %s (%s) => %!" common_prefix path test.Tests.test_name;
73 let (msg, b) = match behavior with
74 | Skip_all_tests -> "n/a", Skip_all_tests
75 | Run env ->
76 let testenv0 = interprete_environment_statements env testenvspec in
77 let testenv = List.fold_left apply_modifiers testenv0 env_modifiers in
78 let (result, newenv) = Tests.run log testenv test in
79 let s = Result.string_of_result result in
80 if Result.is_pass result then (s, Run newenv)
81 else (s, Skip_all_tests) in
82 Printf.printf "%s\n%!" msg;
83 List.iteri (run_test_i log common_prefix path b) subtrees
84 and run_test_i log common_prefix path behavior i test_tree =
85 let path_prefix = if path="" then "" else path ^ "." in
86 let new_path = Printf.sprintf "%s%d" path_prefix (i+1) in
87 run_test log common_prefix new_path behavior test_tree
88
89 let get_test_source_directory test_dirname =
90 if (Filename.is_relative test_dirname) then
91 Sys.with_chdir test_dirname Sys.getcwd
92 else test_dirname
93
94 let get_test_build_directory_prefix test_dirname =
95 let ocamltestdir_variable = "OCAMLTESTDIR" in
96 let root =
97 Sys.getenv_with_default_value ocamltestdir_variable
98 (Filename.concat (Sys.getcwd ()) "_ocamltest")
99 in
100 if test_dirname = "." then root
101 else Filename.concat root test_dirname
102
103 let tests_to_skip = ref []
104
105 let init_tests_to_skip () =
106 tests_to_skip := String.words (Sys.safe_getenv "OCAMLTEST_SKIP_TESTS")
107
108 let test_file test_filename =
109 (* Printf.printf "# reading test file %s\n%!" test_filename; *)
110 (* Save current working directory *)
111 let cwd = Sys.getcwd() in
112 let skip_test = List.mem test_filename !tests_to_skip in
113 let tsl_block = tsl_block_of_file_safe test_filename in
114 let (rootenv_statements, test_trees) = test_trees_of_tsl_block tsl_block in
115 let test_trees = match test_trees with
116 | [] ->
117 let default_tests = Tests.default_tests() in
118 let make_tree test = Node ([], test, [], []) in
119 List.map make_tree default_tests
120 | _ -> test_trees in
121 let used_tests = tests_in_trees test_trees in
122 let used_actions = actions_in_tests used_tests in
123 let action_names =
124 let f act names = String.Set.add (Actions.name act) names in
125 Actions.ActionSet.fold f used_actions String.Set.empty in
126 let test_dirname = Filename.dirname test_filename in
127 let test_basename = Filename.basename test_filename in
128 let test_prefix = Filename.chop_extension test_basename in
129 let test_directory =
130 if test_dirname="." then test_prefix
131 else Filename.concat test_dirname test_prefix in
132 let test_source_directory = get_test_source_directory test_dirname in
133 let hookname_prefix = Filename.concat test_source_directory test_prefix in
134 let test_build_directory_prefix =
135 get_test_build_directory_prefix test_directory in
136 ignore (Sys.command ("rm -rf " ^ test_build_directory_prefix));
137 Sys.make_directory test_build_directory_prefix;
138 Sys.with_chdir test_build_directory_prefix
139 (fun () ->
140 let log =
141 if !Options.log_to_stderr then stderr else begin
142 let log_filename = test_prefix ^ ".log" in
143 open_out log_filename
144 end in
145 let promote = string_of_bool !Options.promote in
146 let install_hook name =
147 let hook_name = Filename.make_filename hookname_prefix name in
148 if Sys.file_exists hook_name then begin
149 let hook = Actions_helpers.run_hook hook_name in
150 Actions.set_hook name hook
151 end in
152 String.Set.iter install_hook action_names;
153
154 let reference_filename = Filename.concat
155 test_source_directory (test_prefix ^ ".reference") in
156 let make = try Sys.getenv "MAKE" with Not_found -> "make" in
157 let initial_environment = Environments.from_bindings
158 [
159 Builtin_variables.make, make;
160 Builtin_variables.test_file, test_basename;
161 Builtin_variables.reference, reference_filename;
162 Builtin_variables.test_source_directory, test_source_directory;
163 Builtin_variables.test_build_directory_prefix,
164 test_build_directory_prefix;
165 Builtin_variables.promote, promote;
166 ] in
167 let root_environment =
168 interprete_environment_statements
169 initial_environment rootenv_statements in
170 let rootenv = Environments.initialize log root_environment in
171 let common_prefix = " ... testing '" ^ test_basename ^ "' with" in
172 let initial_status =
173 if skip_test then Skip_all_tests else Run rootenv
174 in
175 List.iteri
176 (run_test_i log common_prefix "" initial_status)
177 test_trees;
178 Actions.clear_all_hooks();
179 if not !Options.log_to_stderr then close_out log
180 );
181 (* Restore current working directory *)
182 Sys.chdir cwd
183
184 let is_test s =
185 match tsl_block_of_file s with
186 | _ -> true
187 | exception _ -> false
188
189 let ignored s =
190 s = "" || s.[0] = '_' || s.[0] = '.'
191
192 let find_test_dirs dir =
193 let res = ref [] in
194 let rec loop dir =
195 let contains_tests = ref false in
196 Array.iter (fun s ->
197 if ignored s then ()
198 else begin
199 let s = dir ^ "/" ^ s in
200 if Sys.is_directory s then loop s
201 else if not !contains_tests && is_test s then contains_tests := true
202 end
203 ) (Sys.readdir dir);
204 if !contains_tests then res := dir :: !res
205 in
206 loop dir;
207 List.rev !res
208
209 let list_tests dir =
210 let res = ref [] in
211 if Sys.is_directory dir then begin
212 Array.iter (fun s ->
213 if ignored s then ()
214 else begin
215 let s' = dir ^ "/" ^ s in
216 if Sys.is_directory s' || not (is_test s') then ()
217 else res := s :: !res
218 end
219 ) (Sys.readdir dir)
220 end;
221 List.rev !res
222
223 let () =
224 init_tests_to_skip()
225
226 let main () =
227 let failed = ref false in
228 let work_done = ref false in
229 let list_tests dir =
230 match list_tests dir with
231 | [] -> failed := true
232 | res -> List.iter print_endline res
233 in
234 let find_test_dirs dir = List.iter print_endline (find_test_dirs dir) in
235 let doit f x = work_done := true; f x in
236 List.iter (doit find_test_dirs) !Options.find_test_dirs;
237 List.iter (doit list_tests) !Options.list_tests;
238 List.iter (doit test_file) !Options.files_to_test;
239 if not !work_done then print_usage();
240 if !failed || not !work_done then exit 1
241
242 let _ = main()
243