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