1(***********************************************************************)
2(* The OUnit library                                                   *)
3(*                                                                     *)
4(* Copyright (C) 2002, 2003, 2004, 2005 Maas-Maarten Zeeman.           *)
5(* All rights reserved. See LICENCE for details.                       *)
6(***********************************************************************)
7
8let bracket set_up f tear_down () =
9  let fixture = set_up () in
10    try
11      f fixture;
12      tear_down fixture
13    with
14	e ->
15	  tear_down fixture;
16	  raise e
17
18let assert_failure msg =
19  failwith ("OUnit: " ^ msg)
20
21let assert_bool msg b =
22  if not b then assert_failure msg
23
24let assert_string str =
25  if not (str = "") then assert_failure str
26
27let assert_equal ?(cmp = ( = )) ?printer ?msg expected actual  =
28  let get_error_string _ =
29    match printer, msg with
30	None, None -> "not equal"
31      | None, Some s -> (Format.sprintf "%s\nnot equal" s)
32      | Some p, None -> (Format.sprintf "expected: %s but got: %s"
33			   (p expected) (p actual))
34      | Some p, Some s -> (Format.sprintf "%s\nexpected: %s but got: %s"
35			     s (p expected) (p actual))
36  in
37    if not (cmp expected actual) then
38      assert_failure (get_error_string ())
39
40let raises f =
41  try
42    f ();
43    None
44  with
45      e -> Some e
46
47let assert_raises ?msg exn (f: unit -> 'a) =
48  let pexn = Printexc.to_string in
49  let get_error_string _ =
50    let str = Format.sprintf
51      "expected exception %s, but no exception was not raised." (pexn exn)
52    in
53      match msg with
54	  None -> assert_failure str
55	| Some s -> assert_failure (Format.sprintf "%s\n%s" s str)
56  in
57    match raises f with
58	None -> assert_failure (get_error_string ())
59      | Some e -> assert_equal ?msg ~printer:pexn exn e
60
61(* Compare floats up to a given relative error *)
62let cmp_float ?(epsilon = 0.00001) a b =
63  abs_float (a -. b) <= epsilon *. (abs_float a) ||
64    abs_float (a -. b) <= epsilon *. (abs_float b)
65
66(* Now some handy shorthands *)
67let (@?) = assert_bool
68
69(* The type of tests *)
70type test =
71    TestCase of (unit -> unit)
72  | TestList of test list
73  | TestLabel of string * test
74
75(* Some shorthands which allows easy test construction *)
76let (>:) s t = TestLabel(s, t)             (* infix *)
77let (>::) s f = TestLabel(s, TestCase(f))  (* infix *)
78let (>:::) s l = TestLabel(s, TestList(l)) (* infix *)
79
80(* Return the number of available tests *)
81let rec test_case_count test =
82  match test with
83      TestCase _ -> 1
84    | TestLabel (_, t) -> test_case_count t
85    | TestList l -> List.fold_left (fun c t -> c + test_case_count t) 0 l
86
87type node = ListItem of int | Label of string
88type path = node list
89
90let string_of_node node =
91  match node with
92      ListItem n -> (string_of_int n)
93    | Label s -> s
94
95let string_of_path path =
96  List.fold_left
97    (fun a l ->
98       if a = "" then
99	 l
100       else
101	 l ^ ":" ^ a) "" (List.map string_of_node path)
102
103(* Some helper function, they are generally applicable *)
104(* Applies function f in turn to each element in list. Function f takes
105   one element, and integer indicating its location in the list *)
106let mapi f l =
107  let rec rmapi cnt l =
108    match l with
109	[] -> []
110      | h::t -> (f h cnt)::(rmapi (cnt + 1) t)
111  in
112    rmapi 0 l
113
114let fold_lefti f accu l =
115  let rec rfold_lefti cnt accup l =
116    match l with
117	[] -> accup
118      | h::t -> rfold_lefti (cnt + 1) (f accup h cnt) t
119  in
120    rfold_lefti 0 accu l
121
122(* Returns all possible paths in the test. The order is from test case
123   to root
124*)
125let test_case_paths test =
126  let rec tcps path test =
127    match test with
128	TestCase _ -> [path]
129      | TestList tests ->
130	  List.concat (mapi (fun t i -> tcps ((ListItem i)::path) t) tests)
131      | TestLabel (l, t) -> tcps ((Label l)::path) t
132  in
133    tcps [] test
134
135(* The possible test results *)
136type test_result =
137    RSuccess of path
138  | RFailure of path * string
139  | RError of path * string
140
141let is_success = function
142    RSuccess _ -> true
143  | RError _ -> false
144  | RFailure _ -> false
145
146let is_failure = function
147    RFailure _ -> true
148  | RError _ -> false
149  | RSuccess _ -> false
150
151let is_error = function
152    RError _ -> true
153  | RFailure _ -> false
154  | RSuccess _ -> false
155
156let result_flavour = function
157    RError _ -> "Error"
158  | RFailure _ -> "Failure"
159  | RSuccess _ -> "Success"
160
161let result_path = function
162    RSuccess path -> path
163  | RError (path, _) -> path
164  | RFailure (path, _) -> path
165
166let result_msg = function
167    RSuccess _ -> "Success"
168  | RError (_, msg) -> msg
169  | RFailure (_, msg) -> msg
170
171(* Returns true if the result list contains successes only *)
172let rec was_successful results =
173  match results with
174      [] -> true
175    | RSuccess _::t -> was_successful t
176    | RFailure _::_ -> false
177    | RError _::_ -> false
178
179(* Events which can happen during testing *)
180type test_event =
181    EStart of path
182  | EEnd of path
183  | EResult of test_result
184
185(* Run all tests, report starts, errors, failures, and return the results *)
186let perform_test report test =
187  let run_test_case f path =
188    try
189      f ();
190      RSuccess path
191    with
192	Failure s -> RFailure (path, s)
193      | s -> RError (path, (Printexc.to_string s))
194  in
195  let rec run_test path results test =
196    match test with
197	TestCase(f) ->
198	  report (EStart path);
199	  let result = run_test_case f path in
200	    report (EResult result);
201	    report (EEnd path);
202	    result::results
203      | TestList (tests) ->
204	  fold_lefti
205	    (fun results t cnt -> run_test ((ListItem cnt)::path) results t)
206	    results tests
207      | TestLabel (label, t) ->
208	  run_test ((Label label)::path) results t
209  in
210    run_test [] [] test
211
212(* Function which runs the given function and returns the running time
213   of the function, and the original result in a tuple *)
214let time_fun f x y =
215  let begin_time = Unix.gettimeofday () in
216    (Unix.gettimeofday () -. begin_time, f x y)
217
218(* A simple (currently too simple) text based test runner *)
219let run_test_tt ?(verbose=false) test =
220  let printf = Format.printf in
221  let separator1 =
222    "======================================================================" in
223  let separator2 =
224    "----------------------------------------------------------------------" in
225  let string_of_result = function
226      RSuccess _ ->
227	if verbose then "ok\n" else "."
228    | RFailure (_, _) ->
229	if verbose then "FAIL\n" else "F"
230    | RError (_, _) ->
231	if verbose then "ERROR\n" else "E"
232  in
233  let report_event = function
234      EStart p ->
235	if verbose then printf "%s ... " (string_of_path p)
236    | EEnd _ -> ()
237    | EResult result ->
238	printf "%s@?" (string_of_result result);
239  in
240  let print_result_list results =
241      List.iter
242	(fun result -> printf "%s\n%s: %s\n\n%s\n%s\n"
243	   separator1
244	   (result_flavour result)
245	   (string_of_path (result_path result))
246	   (result_msg result)
247	   separator2)
248	results
249  in
250
251  (* Now start the test *)
252  let running_time, results = time_fun perform_test report_event test in
253  let errors = List.filter is_error results in
254  let failures = List.filter is_failure results in
255
256    if not verbose then printf "\n";
257
258    (* Print test report *)
259    print_result_list errors;
260    print_result_list failures;
261    printf "Ran: %d tests in: %.2f seconds.\n"
262      (List.length results) running_time;
263
264    (* Print final verdict *)
265    if was_successful results then
266      printf "OK\n"
267    else
268      printf "FAILED: Cases: %d Tried: %d Errors: %d Failures: %d\n"
269	(test_case_count test) (List.length results)
270	(List.length errors) (List.length failures);
271
272    (* Return the results possibly for further processing *)
273    results
274
275(* Call this one from you test suites *)
276let run_test_tt_main suite =
277  let verbose = ref false in
278  let set_verbose _ = verbose := true in
279
280    Arg.parse
281      [("-verbose", Arg.Unit set_verbose, "Run the test in verbose mode.");]
282      (fun x -> raise (Arg.Bad ("Bad argument : " ^ x)))
283      ("usage: " ^ Sys.argv.(0) ^ " [-verbose]");
284
285    let result = run_test_tt ~verbose:!verbose suite in
286      if not (was_successful result) then
287	exit 1
288      else
289	result
290