462 lines
13 KiB
OCaml
462 lines
13 KiB
OCaml
(***********************************************************************)
|
|
(* The OUnit library *)
|
|
(* *)
|
|
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 *)
|
|
(* Maas-Maarten Zeeman. *)
|
|
|
|
(*
|
|
The package OUnit is copyright by Maas-Maarten Zeeman.
|
|
|
|
Permission is hereby granted, free of charge, to any person obtaining
|
|
a copy of this document and the OUnit software ("the Software"), to
|
|
deal in the Software without restriction, including without limitation
|
|
the rights to use, copy, modify, merge, publish, distribute,
|
|
sublicense, and/or sell copies of the Software, and to permit persons
|
|
to whom the Software is furnished to do so, subject to the following
|
|
conditions:
|
|
|
|
The above copyright notice and this permission notice shall be
|
|
included in all copies or substantial portions of the Software.
|
|
|
|
The Software is provided ``as is'', without warranty of any kind,
|
|
express or implied, including but not limited to the warranties of
|
|
merchantability, fitness for a particular purpose and noninfringement.
|
|
In no event shall Maas-Maarten Zeeman be liable for any claim, damages
|
|
or other liability, whether in an action of contract, tort or
|
|
otherwise, arising from, out of or in connection with the Software or
|
|
the use or other dealings in the software.
|
|
*)
|
|
|
|
(***********************************************************************)
|
|
(* pad: just harmonized some APIs regarding the 'msg' label *)
|
|
|
|
let bracket set_up f tear_down () =
|
|
let fixture = set_up () in
|
|
try
|
|
f fixture;
|
|
tear_down fixture
|
|
with
|
|
e ->
|
|
tear_down fixture;
|
|
raise e
|
|
|
|
exception Skip of string
|
|
let skip_if b msg =
|
|
if b then
|
|
raise (Skip msg)
|
|
|
|
exception Todo of string
|
|
let todo msg =
|
|
raise (Todo msg)
|
|
|
|
let assert_failure msg =
|
|
failwith ("OUnit: " ^ msg)
|
|
|
|
let assert_bool ~msg b =
|
|
if not b then assert_failure msg
|
|
|
|
let assert_string str =
|
|
if not (str = "") then assert_failure str
|
|
|
|
let assert_equal ?(cmp = ( = )) ?printer ?msg expected actual =
|
|
(* pad: better to use dump by default *)
|
|
let p = Dumper.dump in
|
|
|
|
let get_error_string _ =
|
|
match printer, msg with
|
|
None, None ->
|
|
(Format.sprintf "expected: %s but got: %s"
|
|
(p expected) (p actual))
|
|
| None, Some s ->
|
|
(Format.sprintf "%s\nnot equal, expected: %s but got: %s" s
|
|
(p expected) (p actual))
|
|
| Some p, None -> (Format.sprintf "expected: %s but got: %s"
|
|
(p expected) (p actual))
|
|
| Some p, Some s -> (Format.sprintf "%s\nexpected: %s but got: %s"
|
|
s (p expected) (p actual))
|
|
in
|
|
if not (cmp expected actual) then
|
|
assert_failure (get_error_string ())
|
|
|
|
let raises f =
|
|
try
|
|
f ();
|
|
None
|
|
with
|
|
e -> Some e
|
|
|
|
let assert_raises ?msg exn (f: unit -> 'a) =
|
|
let pexn = Printexc.to_string in
|
|
let get_error_string _ =
|
|
let str = Format.sprintf
|
|
"expected exception %s, but no exception was raised." (pexn exn)
|
|
in
|
|
match msg with
|
|
None -> assert_failure str
|
|
| Some s -> assert_failure (Format.sprintf "%s\n%s" s str)
|
|
in
|
|
match raises f with
|
|
None -> assert_failure (get_error_string ())
|
|
| Some e -> assert_equal ?msg ~printer:pexn exn e
|
|
|
|
(* Compare floats up to a given relative error *)
|
|
let cmp_float ?(epsilon = 0.00001) a b =
|
|
abs_float (a -. b) <= epsilon *. (abs_float a) ||
|
|
abs_float (a -. b) <= epsilon *. (abs_float b)
|
|
|
|
(* Now some handy shorthands *)
|
|
let (@?) msg a = assert_bool msg a
|
|
|
|
(* The type of test function *)
|
|
type test_fun = unit -> unit
|
|
|
|
(* The type of tests *)
|
|
type test =
|
|
TestCase of test_fun
|
|
| TestList of test list
|
|
| TestLabel of string * test
|
|
|
|
(* Some shorthands which allows easy test construction *)
|
|
let (>:) s t = TestLabel(s, t) (* infix *)
|
|
let (>::) s f = TestLabel(s, TestCase(f)) (* infix *)
|
|
let (>:::) s l = TestLabel(s, TestList(l)) (* infix *)
|
|
|
|
(* Utility function to manipulate test *)
|
|
let rec test_decorate g tst =
|
|
match tst with
|
|
| TestCase f ->
|
|
TestCase (g f)
|
|
| TestList tst_lst ->
|
|
TestList (List.map (test_decorate g) tst_lst)
|
|
| TestLabel (str, tst) ->
|
|
TestLabel (str, test_decorate g tst)
|
|
|
|
(* Return the number of available tests *)
|
|
let rec test_case_count test =
|
|
match test with
|
|
TestCase _ -> 1
|
|
| TestLabel (_, t) -> test_case_count t
|
|
| TestList l -> List.fold_left (fun c t -> c + test_case_count t) 0 l
|
|
|
|
type node = ListItem of int | Label of string
|
|
type path = node list
|
|
|
|
let string_of_node node =
|
|
match node with
|
|
ListItem n -> (string_of_int n)
|
|
| Label s -> s
|
|
|
|
let string_of_path path =
|
|
List.fold_left
|
|
(fun a l ->
|
|
if a = "" then
|
|
l
|
|
else
|
|
l ^ ":" ^ a) "" (List.map string_of_node path)
|
|
|
|
(* Some helper function, they are generally applicable *)
|
|
(* Applies function f in turn to each element in list. Function f takes
|
|
one element, and integer indicating its location in the list *)
|
|
let mapi f l =
|
|
let rec rmapi cnt l =
|
|
match l with
|
|
[] -> []
|
|
| h::t -> (f h cnt)::(rmapi (cnt + 1) t)
|
|
in
|
|
rmapi 0 l
|
|
|
|
let fold_lefti f accu l =
|
|
let rec rfold_lefti cnt accup l =
|
|
match l with
|
|
[] -> accup
|
|
| h::t -> rfold_lefti (cnt + 1) (f accup h cnt) t
|
|
in
|
|
rfold_lefti 0 accu l
|
|
|
|
(* Returns all possible paths in the test. The order is from test case
|
|
to root
|
|
*)
|
|
let test_case_paths test =
|
|
let rec tcps path test =
|
|
match test with
|
|
TestCase _ -> [path]
|
|
| TestList tests ->
|
|
List.concat (mapi (fun t i -> tcps ((ListItem i)::path) t) tests)
|
|
| TestLabel (l, t) -> tcps ((Label l)::path) t
|
|
in
|
|
tcps [] test
|
|
|
|
(* Test filtering with their path *)
|
|
module SetTestPath = Set.Make(String)
|
|
|
|
let test_filter only test =
|
|
let set_test =
|
|
List.fold_left
|
|
(fun st str -> SetTestPath.add str st)
|
|
SetTestPath.empty
|
|
only
|
|
in
|
|
let foldi f acc lst =
|
|
List.fold_left
|
|
(fun (i, acc) e ->
|
|
let nacc =
|
|
f i acc e
|
|
in
|
|
(i + 1), nacc
|
|
)
|
|
acc
|
|
lst
|
|
in
|
|
let rec filter_test path tst =
|
|
if SetTestPath.mem (string_of_path path) set_test then
|
|
(
|
|
Some tst
|
|
)
|
|
else
|
|
(
|
|
match tst with
|
|
| TestCase _ ->
|
|
None
|
|
| TestList tst_lst ->
|
|
let (_, ntst_lst) =
|
|
foldi
|
|
(fun i ntst_lst tst ->
|
|
let nntst_lst =
|
|
match filter_test ((ListItem i) :: path) tst with
|
|
| Some tst ->
|
|
tst :: ntst_lst
|
|
| None ->
|
|
ntst_lst
|
|
in
|
|
nntst_lst
|
|
)
|
|
(0, [])
|
|
tst_lst
|
|
in
|
|
if ntst_lst = [] then
|
|
None
|
|
else
|
|
Some (TestList ntst_lst)
|
|
| TestLabel (lbl, tst) ->
|
|
let ntst =
|
|
filter_test
|
|
((Label lbl) :: path)
|
|
tst
|
|
in
|
|
match ntst with
|
|
| Some tst ->
|
|
Some (TestLabel (lbl, tst))
|
|
| None ->
|
|
None
|
|
)
|
|
in
|
|
filter_test [] test
|
|
|
|
|
|
(* The possible test results *)
|
|
type test_result =
|
|
RSuccess of path
|
|
| RFailure of path * string
|
|
| RError of path * string
|
|
| RSkip of path * string
|
|
| RTodo of path * string
|
|
|
|
let is_success = function
|
|
RSuccess _ -> true
|
|
| RFailure _ | RError _ | RSkip _ | RTodo _ -> false
|
|
|
|
let is_failure = function
|
|
RFailure _ -> true
|
|
| RSuccess _ | RError _ | RSkip _ | RTodo _ -> false
|
|
|
|
let is_error = function
|
|
RError _ -> true
|
|
| RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> false
|
|
|
|
let is_skip = function
|
|
RSkip _ -> true
|
|
| RSuccess _ | RFailure _ | RError _ | RTodo _ -> false
|
|
|
|
let is_todo = function
|
|
RTodo _ -> true
|
|
| RSuccess _ | RFailure _ | RError _ | RSkip _ -> false
|
|
|
|
let result_flavour = function
|
|
RError _ -> "Error"
|
|
| RFailure _ -> "Failure"
|
|
| RSuccess _ -> "Success"
|
|
| RSkip _ -> "Skip"
|
|
| RTodo _ -> "Todo"
|
|
|
|
let result_path = function
|
|
RSuccess path
|
|
| RError (path, _)
|
|
| RFailure (path, _)
|
|
| RSkip (path, _)
|
|
| RTodo (path, _) -> path
|
|
|
|
let result_msg = function
|
|
RSuccess _ -> "Success"
|
|
| RError (_, msg)
|
|
| RFailure (_, msg)
|
|
| RSkip (_, msg)
|
|
| RTodo (_, msg) -> msg
|
|
|
|
(* Returns true if the result list contains successes only *)
|
|
let rec was_successful results =
|
|
match results with
|
|
[] -> true
|
|
| RSuccess _::t
|
|
| RSkip _::t -> was_successful t
|
|
| RFailure _::_
|
|
| RError _::_
|
|
| RTodo _::_ -> false
|
|
|
|
(* Events which can happen during testing *)
|
|
type test_event =
|
|
EStart of path
|
|
| EEnd of path
|
|
| EResult of test_result
|
|
|
|
(* Run all tests, report starts, errors, failures, and return the results *)
|
|
let perform_test report test =
|
|
let run_test_case f path =
|
|
try
|
|
f ();
|
|
RSuccess path
|
|
with
|
|
Failure s -> RFailure (path, s)
|
|
| Skip s -> RSkip (path, s)
|
|
| Todo s -> RTodo (path, s)
|
|
| s -> RError (path, (Printexc.to_string s ^ " " ^
|
|
Printexc.get_backtrace ()))
|
|
in
|
|
let rec run_test path results test =
|
|
match test with
|
|
TestCase(f) ->
|
|
report (EStart path);
|
|
let result = run_test_case f path in
|
|
report (EResult result);
|
|
report (EEnd path);
|
|
result::results
|
|
| TestList (tests) ->
|
|
fold_lefti
|
|
(fun results t cnt -> run_test ((ListItem cnt)::path) results t)
|
|
results tests
|
|
| TestLabel (label, t) ->
|
|
run_test ((Label label)::path) results t
|
|
in
|
|
run_test [] [] test
|
|
|
|
(* Function which runs the given function and returns the running time
|
|
of the function, and the original result in a tuple *)
|
|
let time_fun f x y =
|
|
let begin_time = Unix.gettimeofday () in
|
|
(Unix.gettimeofday () -. begin_time, f x y)
|
|
|
|
(* A simple (currently too simple) text based test runner *)
|
|
let run_test_tt ?(verbose=false) test =
|
|
let printf = Format.printf in
|
|
let separator1 =
|
|
"======================================================================" in
|
|
let separator2 =
|
|
"----------------------------------------------------------------------" in
|
|
let string_of_result = function
|
|
RSuccess _ ->
|
|
if verbose then "ok\n" else "."
|
|
| RFailure (_, _) ->
|
|
if verbose then "FAIL\n" else "F"
|
|
| RError (_, _) ->
|
|
if verbose then "ERROR\n" else "E"
|
|
| RSkip (_, _) ->
|
|
if verbose then "SKIP\n" else "S"
|
|
| RTodo (_, _) ->
|
|
if verbose then "TODO\n" else "T"
|
|
in
|
|
let report_event = function
|
|
EStart p ->
|
|
if verbose then printf "%s ... " (string_of_path p)
|
|
| EEnd _ -> ()
|
|
| EResult result ->
|
|
printf "%s@?" (string_of_result result);
|
|
in
|
|
let print_result_list results =
|
|
List.iter
|
|
(fun result -> printf "%s\n%s: %s\n\n%s\n%s\n"
|
|
separator1
|
|
(result_flavour result)
|
|
(string_of_path (result_path result))
|
|
(result_msg result)
|
|
separator2)
|
|
results
|
|
in
|
|
|
|
(* Now start the test *)
|
|
let running_time, results = time_fun perform_test report_event test in
|
|
let errors = List.filter is_error results in
|
|
let failures = List.filter is_failure results in
|
|
let skips = List.filter is_skip results in
|
|
let todos = List.filter is_todo results in
|
|
|
|
if not verbose then printf "\n";
|
|
|
|
(* Print test report *)
|
|
print_result_list errors;
|
|
print_result_list failures;
|
|
printf "Ran: %d tests in: %.2f seconds.\n"
|
|
(List.length results) running_time;
|
|
|
|
(* Print final verdict *)
|
|
if was_successful results then
|
|
(
|
|
if skips = [] then
|
|
printf "OK"
|
|
else
|
|
printf "OK: Cases: %d Skip: %d\n"
|
|
(test_case_count test) (List.length skips)
|
|
)
|
|
else
|
|
printf "FAILED: Cases: %d Tried: %d Errors: %d Failures: %d Skip:%d Todo:%d\n"
|
|
(test_case_count test) (List.length results)
|
|
(List.length errors) (List.length failures)
|
|
(List.length skips) (List.length todos);
|
|
|
|
(* Return the results possibly for further processing *)
|
|
results
|
|
|
|
(* Call this one from you test suites *)
|
|
let run_test_tt_main suite =
|
|
let verbose = ref false in
|
|
let only_test = ref [] in
|
|
|
|
Arg.parse
|
|
(Arg.align
|
|
[("-verbose", Arg.Set verbose, " Run the test in verbose mode.");
|
|
("-only-test", Arg.String (fun str -> only_test := str :: !only_test),
|
|
"path Run only the selected test");
|
|
]
|
|
)
|
|
(fun x -> raise (Arg.Bad ("Bad argument : " ^ x)))
|
|
("usage: " ^ Sys.argv.(0) ^ " [-verbose] [-only-test path]*");
|
|
|
|
let nsuite =
|
|
if !only_test = [] then
|
|
(
|
|
suite
|
|
)
|
|
else
|
|
(
|
|
match test_filter !only_test suite with
|
|
| Some tst ->
|
|
tst
|
|
| None ->
|
|
failwith ("Filtering test "^
|
|
(String.concat ", " !only_test)^
|
|
" lead to no test")
|
|
)
|
|
in
|
|
let result = run_test_tt ~verbose:!verbose nsuite in
|
|
if not (was_successful result) then
|
|
exit 1
|
|
else
|
|
result
|