swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

29
unikernel/duniverse/bos/test/test.ml Normal file
View file

@ -0,0 +1,29 @@
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
---------------------------------------------------------------------------*)
let tests () = Testing.run
[ Test_pat.suite;
Test_cmd.suite;
Test_os_cmd.suite; ]
let run () = tests (); Testing.log_results ()
let () = if run () then exit 0 else exit 1
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)

39
unikernel/duniverse/bos/test/test_arg.ml Normal file
View file

@ -0,0 +1,39 @@
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
---------------------------------------------------------------------------*)
open Bos
let debug = OS.Arg.(flag ["g"; "debug"] ~env:"DEBUG" ~doc:"Debug mode.")
let count = OS.Arg.(flag_all ["c"] ~doc:"Count me.")
let print_parse () =
Logs.app (fun m -> m "debug: %b" debug);
Logs.app (fun m -> m "count: %d" count);
()
let main () =
Logs.set_reporter (Logs_fmt.reporter ());
OS.Arg.parse_opts ();
print_parse ();
()
let () = main ()
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)

44
unikernel/duniverse/bos/test/test_arg_pos.ml Normal file
View file

@ -0,0 +1,44 @@
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
---------------------------------------------------------------------------*)
open Bos
let debug = OS.Arg.(flag ["g"; "debug"] ~env:"DEBUG" ~doc:"Debug mode.")
let () = Fmt.(set_style_renderer stdout `Ansi_tty)
let print_parse depth ints =
Logs.app (fun m -> m "debug: %b" debug);
Logs.app (fun m -> m "depth: %d" depth);
Logs.app (fun m -> m "pos: @[%a@]" Fmt.(list ~sep:sp int) ints);
()
let main () =
Logs.set_reporter (Logs_fmt.reporter ());
let depth =
OS.Arg.(opt ["d"; "depth"] int ~absent:2
~doc:"Specifies depth of $(docv) iterations.")
in
let doc = "Testing the OS.Arg module." in
print_parse depth (OS.Arg.(parse ~doc ~pos:int ()))
let () = main ()
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)

47
unikernel/duniverse/bos/test/test_cmd.ml Normal file
View file

@ -0,0 +1,47 @@
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
---------------------------------------------------------------------------*)
open Testing
open Rresult
open Astring
open Bos
let of_string = test "Cmd.of_string" @@ fun () ->
let eq cmd l = match Cmd.of_string cmd with
| Error (`Msg msg) -> fail "%s" msg
| Ok l' -> eq_list ~eq:(=) ~pp:pp_str (Cmd.to_list l') l
in
eq "" [];
eq "bla" ["bla"];
eq " bla bli" ["bla"; "bli"];
eq " bla bli " ["bla"; "bli"];
eq " bla b\\li " ["bla"; "b\\li"];
eq " b'haha'la bli " ["bhahala"; "bli"];
eq " b\"haha\"la bli " ["bhahala"; "bli"];
eq " b\"'\"la bli " ["b'la"; "bli"];
eq " b''''la bli " ["bla"; "bli"];
eq " b'u'\"'\"'i'la bli " ["bu'ila"; "bli"];
eq " b\"\\\"\"ila bli " ["b\"ila"; "bli"];
eq " b\"\\\n\"ila bli " ["bila"; "bli"];
()
let suite = suite "Cmd module"
[ of_string; ]
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)

76
unikernel/duniverse/bos/test/test_os_cmd.ml Normal file
View file

@ -0,0 +1,76 @@
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
---------------------------------------------------------------------------*)
open Testing
open Astring
open Rresult
open Bos
let eqb = eq_result_msg ~eq_ok:(=) ~pp_ok:pp_bool
let eqs = eq_result_msg ~eq_ok:(=) ~pp_ok:pp_str
let equ = eq_result_msg ~eq_ok:(=) ~pp_ok:pp_unit
let eql = eq_result_msg ~eq_ok:(=) ~pp_ok:(pp_list pp_str)
let cat = Cmd.(v "cat")
let cat_stdin = Cmd.(cat % "-")
let unlikely = Cmd.v "6AC0E501-4E30-4CBC-AD03-F880F885BC18"
let exists = test "OS.Cmd.exists" @@ fun () ->
eqb (OS.Cmd.exists cat) (Ok true);
eqb (OS.Cmd.exists unlikely) (Ok false);
()
let must_exist = test "OS.Cmd.must_exist" @@ fun () ->
begin match (OS.Cmd.must_exist cat) with
| Error (`Msg err) -> fail "%s" err
| Ok _ -> ()
end;
begin match (OS.Cmd.must_exist unlikely) with
| Ok _ -> fail "%a exists" Cmd.dump unlikely
| Error _ -> ()
end;
()
let run_io = test "OS.Cmd.run_io" @@ fun () ->
let in_hey = OS.Cmd.in_string "hey" in
let tmp () = OS.File.tmp "bos_test_%s" in
eqs OS.Cmd.(in_hey |> run_io cat_stdin |> to_string) (Ok "hey");
eql OS.Cmd.(in_string "hey\nho\n" |> run_io cat_stdin |> to_lines)
(Ok ["hey";"ho"]);
equ OS.Cmd.(in_hey |> run_io cat_stdin |> to_null) (Ok ());
eqs (tmp ()
>>= fun tmp -> OS.Cmd.(in_hey |> run_io cat_stdin |> to_file tmp)
>>= fun () -> OS.Cmd.(in_hey |> run_io cat |> to_file tmp ~append:true)
>>= fun () -> OS.Cmd.(in_file tmp |> run_io Cmd.(cat_stdin % p tmp) |>
to_string))
(Ok "heyheyheyhey");
eqs (tmp ()
>>= fun tmp1 -> tmp()
>>= fun tmp2 -> OS.Cmd.(in_hey |> run_io cat_stdin |> to_file tmp1)
>>= fun () -> OS.Cmd.(in_file tmp1 |> run_io cat_stdin |> out_run_in)
>>= fun pipe -> OS.Cmd.(pipe |> run_io cat_stdin |> to_file tmp2)
>>= fun () -> OS.Cmd.(in_file tmp2 |> run_io cat_stdin |> to_string))
(Ok "hey");
()
let suite = suite "OS command run functions"
[ exists;
run_io; ]
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)

116
unikernel/duniverse/bos/test/test_pat.ml Normal file
View file

@ -0,0 +1,116 @@
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
---------------------------------------------------------------------------*)
open Testing
open Astring
open Bos
let eqp = eq ~eq:Pat.equal ~pp:Pat.pp
let v = Fpath.v
let string_conv = test "Pat.{v,of_string,to_string}" @@ fun () ->
let trip p = eq_str p Pat.(to_string (v p)) in
app_invalid ~pp:Pat.pp Pat.v "$(";
app_invalid ~pp:Pat.pp Pat.v "$(a";
app_invalid ~pp:Pat.pp Pat.v "$$$(";
app_invalid ~pp:Pat.pp Pat.v "$$$";
app_invalid ~pp:Pat.pp Pat.v "$(bla,)";
app_invalid ~pp:Pat.pp Pat.v "$(b,la)";
trip "Hey $(ho)";
trip "Hey $(ho) $(hu)";
trip "Hey $(ho) $(h$u)";
trip "Hey mo $$(hu)";
trip "Hey mo $$30";
trip "Hey mo $$$$";
()
let dom = test "Pat.dom" @@ fun () ->
let eq s l =
eq ~eq:String.Set.equal ~pp:String.Set.dump
(Pat.(dom @@ v s)) (String.Set.of_list l)
in
eq "bla" [];
eq "bla ha $$" [];
eq "hey $(bla)" ["bla"];
eq "hey $(bla) $()" ["bla"; ""];
eq "hey $(bla) $$(ha) $()" ["bla"; ""];
eq "hey $(bla) $(bli) $()" ["bla"; "bli"; ""];
()
let subst = test "Pat.subst" @@ fun () ->
let eq ?undef defs p s =
eq_str Pat.(to_string @@ subst ?undef defs (v p)) s
in
let defs = String.Map.of_list ["bli", "bla"] in
let undef = function "blu" -> Some "bla$" | _ -> None in
eq ~undef defs "hey $$ $(bli) $(bla) $(blu)" "hey $$ bla $(bla) bla$$";
eq defs "hey $(blo) $(bla) $(blu)" "hey $(blo) $(bla) $(blu)";
()
let format = test "Pat.format" @@ fun () ->
let eq ?undef defs p s = eq_str (Pat.(format ?undef defs (v p))) s in
let defs = String.Map.of_list ["hey", "ho"; "hi", "ha$"] in
let undef = fun _ -> "undef" in
eq ~undef defs "a $$ $(hu)" "a $ undef";
eq ~undef defs "a $(hey) $(hi)" "a ho ha$";
eq defs "a $$(hey) $$(hi) $(ha)" "a $(hey) $(hi) ";
()
let matches = test "Pat.matches" @@ fun () ->
let m p s = Pat.(matches (v p) s) in
eq_bool (m "$(mod).mli" "string.mli") true;
eq_bool (m "$(mod).mli" "string.mli ") false;
eq_bool (m "$(mod).mli" ".mli") true;
eq_bool (m "$(mod).mli" ".mli ") false;
eq_bool (m "$(mod).$(suff)" "string.mli") true;
eq_bool (m "$(mod).$(suff)" "string.mli ") true;
eq_bool (m "$()aaa" "aaa") true;
eq_bool (m "aaa$()" "aaa") true;
eq_bool (m "$()a$()aa$()" "aaa") true;
()
let query = test "Pat.query" @@ fun () ->
let u ?init p s = Pat.(query ?init (v p) s) in
let eq = eq_option
~eq:(String.Map.equal String.equal) ~pp:(String.Map.dump String.dump)
in
let eq ?init p s = function
| None -> eq (u ?init p s) None
| Some l -> eq (u ?init p s) (Some (String.Map.of_list l))
in
let init = String.Map.of_list ["hey", "ho"] in
eq "$(mod).mli" "string.mli" (Some ["mod", "string"]);
eq ~init "$(mod).mli" "string.mli" (Some ["mod", "string"; "hey", "ho"]);
eq "$(mod).mli" "string.mli " None;
eq ~init "$(mod).mli" "string.mli " None;
eq "$(mod).mli" "string.mli " None;
eq "$(mod).$(suff)" "string.mli" (Some ["mod", "string"; "suff", "mli"]);
eq "$(mod).$(suff)" "string.mli" (Some ["mod", "string"; "suff", "mli"]);
eq "$(m).$(m)" "string.mli" (Some ["m", "string"]);
()
let suite = suite "Pat module"
[ string_conv;
dom;
subst;
format;
matches;
query; ]
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)

285
unikernel/duniverse/bos/test/testing.ml Normal file
View file

@ -0,0 +1,285 @@
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
---------------------------------------------------------------------------*)
open Rresult
(* Value equality and pretty printing *)
type 'a eq = 'a -> 'a -> bool
type 'a pp = Format.formatter -> 'a -> unit
(* Pretty printers *)
let pp = Format.fprintf
let pp_unit ppf v = pp ppf "()"
let pp_exn ppf v = pp ppf "%s" (Printexc.to_string v)
let pp_bool ppf v = pp ppf "%b" v
let pp_char ppf v = pp ppf "%C" v
let pp_str ppf v = pp ppf "%S" v
let pp_int = Format.pp_print_int
let pp_float ppf v = pp ppf "%.10f" (* bof... *) v
let pp_int32 ppf v = pp ppf "%ld" v
let pp_int64 ppf v = pp ppf "%Ld" v
let pp_text = Format.pp_print_text
let pp_list pp_v ppf l =
let pp_sep ppf () = pp ppf ";@," in
pp ppf "@[<1>[%a]@]" (Format.pp_print_list ~pp_sep pp_v) l
let pp_option pp_v ppf = function
| None -> Format.fprintf ppf "None"
| Some v -> Format.fprintf ppf "Some %a" pp_v v
let pp_slot_loc ppf l =
pp ppf "%s:%d.%d-%d:"
l.Printexc.filename l.Printexc.line_number
l.Printexc.start_char l.Printexc.end_char
let pp_bt ppf bt = match Printexc.backtrace_slots bt with
| None -> pp ppf "@,@[%a@]" pp_text "No backtrace. Did you compile with -g ?"
| Some slots ->
let rec loop = function
| [] -> assert false
| s :: ss ->
begin match Printexc.Slot.location s with
| None -> ()
| Some l when l.Printexc.filename = "test/testing.ml" ||
l.Printexc.filename = "test/test.ml" -> ()
| Some l -> pp ppf "@,%a" pp_slot_loc l
end;
if ss <> [] then (loop ss) else ()
in
loop (Array.to_list slots)
(* Assertion counters *)
let fail_count = ref 0
let pass_count = ref 0
(* Logging *)
let log_part fmt = Format.printf fmt
let log ?header fmt = match header with
| Some h -> Format.printf ("[%s] " ^^ fmt ^^ "@.") h
| None -> Format.printf (fmt ^^ "@.")
let log_results () =
let total = !pass_count + !fail_count in
match !fail_count with
| 0 -> log ~header:"OK" "All %d assertions succeeded !@." total; true
| 1 -> log ~header:"FAIL" "1 failure out of %d assertions" total; false
| n -> log ~header:"FAIL" "%d failures out of %d assertions"
!fail_count total; false
let log_fail msg bt =
log ~header:"FAIL" "@[<v>@[%a@]%a@]" pp_text msg pp_bt bt
let log_unexpected_exn ~header exn bt =
log ~header:"SUITE" "@[<v>@[ABORTED: unexpected exception:@]@,%a%a@]"
pp_exn exn pp_bt bt
(* Testing scopes *)
exception Fail
exception Fail_handled
let block f = try f () with
| Fail | Fail_handled -> ()
| exn ->
let bt = Printexc.get_raw_backtrace () in
incr fail_count;
log_unexpected_exn ~header:"BLOCK" exn bt
type test = string * (unit -> unit)
let test n f = n, f
let run_test (n, f) =
log "* %s" n;
try f () with
| Fail | Fail_handled ->
log ~header:"TEST" "ABORTED: a test failure blew the test scope"
| exn ->
let bt = Printexc.get_raw_backtrace () in
incr fail_count;
log_unexpected_exn ~header:"TEST" exn bt
type suite = string * test list
let suite n ts = n, ts
let run_suite (n, ts) = try log "%s" n; List.iter run_test ts with
| exn ->
let bt = Printexc.get_raw_backtrace () in
incr fail_count;
log_unexpected_exn ~header:"SUITE" exn bt
let run suites = List.iter run_suite suites
(* Passing and failing tests *)
let pass () = incr pass_count
let fail fmt =
let bt = Printexc.get_callstack 10 in
let fail _ = log_fail (Format.flush_str_formatter ()) bt in
(incr fail_count; Format.kfprintf fail Format.str_formatter fmt)
(* Checking values *)
let pp_neq pp_v ppf (v, v') = pp ppf "@[%a@]@ <>@ @[%a@]@]" pp_v v pp_v v'
let fail_eq pp v v' = fail "%a" (pp_neq pp) (v, v')
let eq ~eq ~pp v v' = if eq v v' then pass () else fail_eq pp v v'
let eq_char = eq ~eq:(=) ~pp:pp_char
let eq_str = eq ~eq:(=) ~pp:pp_str
let eq_bool = eq ~eq:(=) ~pp:Format.pp_print_bool
let eq_int = eq ~eq:(=) ~pp:Format.pp_print_int
let eq_int32 = eq ~eq:(=) ~pp:pp_int32
let eq_int64 = eq ~eq:(=) ~pp:pp_int64
let eq_float = eq ~eq:(=) ~pp:pp_float
let eq_nan f =
if f <> f then pass () else fail "@[%a@]@ is@ not a NaN" pp_float f
let eq_option ~eq:eq_v ~pp =
let eq_opt v v' = match v, v' with
| Some v, Some v' -> eq_v v v'
| None, None -> true
| _ -> false
in
let pp = pp_option pp in
fun v v' -> eq ~eq:eq_opt ~pp v v'
let eq_some = function
| Some _ -> pass ()
| None -> fail "None <> Some _"
let eq_none ~pp = function
| None -> pass ()
| Some v -> fail "@[%a <>@ None@]" pp v
let eq_list ~eq:eq_v ~pp:pp_v =
let eql l l' = try List.for_all2 eq_v l l' with Invalid_argument _ -> false in
fun l l' -> eq ~eq:eql ~pp:(pp_list pp_v) l l'
let eq_result ~eq_ok ~pp_ok ~eq_error ~pp_error =
let eqr v v' = match v, v' with
| Ok v, Ok v' -> eq_ok v v'
| Error e, Error e' -> eq_error e e'
| _ -> false
in
let pp ppf r = Rresult.R.pp ~ok:pp_ok ~error:pp_error ppf r in
fun v v' -> eq ~eq:eqr ~pp v v'
let eq_result_msg ~eq_ok ~pp_ok =
let eq_error (`Msg e) (`Msg e') = (e = e') in
eq_result ~eq_ok ~pp_ok ~eq_error:eq_error ~pp_error:R.pp_msg
let eq_ok ~eq:eq_v ~pp:pp_v =
let eq_ok v v' = match v, v' with
| Ok v, Ok v' -> eq_v v v'
| Error _, _-> false
| _ -> assert false
in
let pp ppf = function
| Ok v -> Format.fprintf ppf "@[Ok %a@]" pp_v v
| Error _ -> Format.fprintf ppf "@[Error _@]"
in
fun v v' -> eq ~eq:eq_ok ~pp v (Ok v')
(* Tracing and checking function applications. *)
type app = (* Gathers information about the application *)
{ fail_count : int; (* fail_count checkpoint when the app starts *)
pp_args : Format.formatter -> unit -> unit; }
let ctx () = { fail_count = -1; pp_args = fun ppf () -> (); }
let log_app_raised app exn =
log "@[<2>@[%a@]==> raised %a" app.pp_args () pp_exn exn
let pp_app app pp_v ppf v =
pp ppf "@[<2>@[%a@]==>@ @[%a@]@]" app.pp_args () pp_v v
let log_app app pp_v v = log "%a" (pp_app app pp_v) v
let ( $ ) f k = k (ctx ()) f
let ( @-> ) (pp_v : 'a pp) k app f v =
let pp_args ppf () = app.pp_args ppf (); pp ppf "%a@ " pp_v v in
let fc = if app.fail_count = -1 then !fail_count else app.fail_count in
let app = { fail_count = fc; pp_args } in
try k app (f v) with
| Fail ->
log_app app pp_v v;
raise Fail_handled
| Fail_handled as e -> raise e
| exn ->
log_app_raised app exn;
fail "unexpected exception %a raised" pp_exn exn;
raise Fail_handled
let ret pp app v =
if !fail_count <> app.fail_count then log_app app pp v;
v
let ret_eq ~eq pp r app v =
if eq r v then (pass (); ret pp app v) else
(fail "@[<v>%a@,%a@]" (pp_neq pp) (r, v) (pp_app app pp) v;
raise Fail_handled)
let ret_none pp app v = match v with
| None -> pass (); ret (pp_option pp) app v
| Some _ -> ret_eq ~eq:(=) (pp_option pp) None app v
let ret_some pp app v = match v with
| Some _ as v -> pass (); ret (pp_option pp) app v
| None as v ->
fail "@[<v>Some _ <> None@,%a@]" (pp_app app (pp_option pp)) v;
raise Fail_handled
let ret_get_option pp app v = match ret_some pp app v with
| Some v -> v
| None -> assert false
(* I think we could handle the following functions on app traced ones
by enriching the app type and have alternate functions to $ for
handling these cases. Note that the only place were we can check
for these things are in the @-> combinator *)
let app_invalid ~pp f v =
try
let r = f v in
fail "%a <> exception Invalid_arg _" pp r
with
| Invalid_argument _ -> pass ()
| exn -> fail "exception %a <> exception Invalid_arg _" pp_exn exn
let app_exn ~pp e f v =
try
let r = f v in
fail "%a <> exception %a" pp r pp_exn e
with
| exn when exn = e -> pass ()
| exn -> fail "exception %a <> exception %a_" pp_exn exn pp_exn e
let app_raises ~pp f v =
try
let r = f v in
fail "%a <> exception _ " pp r
with
| exn -> pass ()
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)

104
unikernel/duniverse/bos/test/testing.mli Normal file
View file

@ -0,0 +1,104 @@
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
---------------------------------------------------------------------------*)
open Rresult
(* {1 Value equality and pretty printing} *)
type 'a eq = 'a -> 'a -> bool
type 'a pp = Format.formatter -> 'a -> unit
(* {1 Pretty printers} *)
val pp_unit : unit pp
val pp_int : int pp
val pp_bool : bool pp
val pp_float : float pp
val pp_char : char pp
val pp_str : string pp
val pp_list : 'a pp -> 'a list pp
val pp_option : 'a pp -> 'a option pp
(* {1 Logging} *)
val log_part : ('a, Format.formatter, unit) format -> 'a
val log : ?header:string -> ('a, Format.formatter, unit) format -> 'a
val log_results : unit -> bool
(* {1 Testing scopes} *)
type test
type suite
val block : (unit -> unit) -> unit
val test : string -> (unit -> unit) -> test
val suite : string -> test list -> suite
val run : suite list -> unit
(* {1 Passing and failing tests} *)
val pass : unit -> unit
val fail : ('a, Format.formatter, unit, unit) format4 -> 'a
(* {1 Checking values} *)
val eq : eq:'a eq -> pp:'a pp -> 'a -> 'a -> unit
val eq_char : char -> char -> unit
val eq_str : string -> string -> unit
val eq_bool : bool -> bool -> unit
val eq_int : int -> int -> unit
val eq_int32 : int32 -> int32 -> unit
val eq_int64 : int64 -> int64 -> unit
val eq_float : float -> float -> unit
val eq_nan : float -> unit
val eq_option : eq:'a eq -> pp:'a pp -> 'a option -> 'a option -> unit
val eq_some : 'a option -> unit
val eq_none : pp:'a pp -> 'a option -> unit
val eq_list : eq:'a eq -> pp:'a pp -> 'a list -> 'a list -> unit
val eq_result : eq_ok:'a eq -> pp_ok:'a pp -> eq_error:'b eq ->
pp_error:'b pp -> ('a, 'b) result -> ('a, 'b) result -> unit
val eq_result_msg : eq_ok:'a eq -> pp_ok:'a pp ->
('a, [`Msg of string]) result -> ('a, [`Msg of string]) result -> unit
val eq_ok : eq:'a eq -> pp:'a pp -> ('a, 'b) result -> 'a -> unit
(* {1 Tracing and checking function applications} *)
type app (* holds information about the application *)
val ( $ ) : 'a -> (app -> 'a -> 'b) -> 'b
val ( @-> ) : 'a pp -> (app -> 'b -> 'c) -> app -> ('a -> 'b) -> 'a -> 'c
val ret : 'a pp -> app -> 'a -> 'a
val ret_eq : eq:'a eq -> 'a pp -> 'a -> app -> 'a -> 'a
val ret_some : 'a pp -> app -> 'a option -> 'a option
val ret_none : 'a pp -> app -> 'a option -> 'a option
val ret_get_option : 'a pp -> app -> 'a option -> 'a
val app_invalid : pp:'b pp -> ('a -> 'b) -> 'a -> unit
val app_exn : pp:'b pp -> exn -> ('a -> 'b) -> 'a -> unit
val app_raises : pp:'b pp -> ('a -> 'b) -> 'a -> unit
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)

78
unikernel/duniverse/bos/test/watch.ml Normal file
View file

@ -0,0 +1,78 @@
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
---------------------------------------------------------------------------*)
open Bos_setup
(* Watch a directory for changes. First run will create a database
watchdb in the directory with modification times. Subsquent runs
will check files against that database. *)
module Db = struct
let db_file = Fpath.v "watchdb"
let exists () = OS.File.exists db_file
let scan () = (* returns list of (path, modification time) *)
let add p acc =
(OS.Path.stat p >>= fun stats ->
if stats.Unix.st_kind <> Unix.S_REG then Ok acc else
Ok ((p, stats.Unix.st_mtime) :: acc))
|> Logs.on_error_msg ~use:(fun _ -> acc)
in
Logs.app (fun m -> m "Scanning files");
OS.Dir.current () >>= fun dir ->
OS.Dir.fold_contents ~dotfiles:true ~elements:`Files add [] dir
let dump oc db = Ok (Marshal.(to_channel oc db [No_sharing; Compat_32]))
let slurp ic () = (Marshal.from_channel ic : float Fpath.Map.t)
let create files =
Logs.app (fun m -> m "Writing modification time database %a"
Fpath.pp db_file);
let count = ref 0 in
let add acc (f, time) = incr count; Fpath.Map.add f time acc in
let db = List.fold_left add Fpath.Map.empty files in
R.join @@ OS.File.with_oc db_file dump db >>= fun () -> Ok !count
let check files =
let count = ref 0 in
let changes db (f, time) = match (incr count; Fpath.Map.find f db) with
| None ->
Logs.app (fun m -> m "New file: %a" Fpath.pp f)
| Some stamp when stamp <> time ->
Logs.app (fun m -> m "File changed: %a" Fpath.pp f)
| _ -> ()
in
Logs.app (fun m -> m "Checking against %a" Fpath.pp db_file);
OS.File.with_ic db_file slurp ()
>>= fun db -> List.iter (changes db) files; Ok !count
end
let watch () =
Db.scan ()
>>= fun files -> Db.exists ()
>>= fun exists -> if exists then Db.check files else Db.create files
let main () =
let c = Mtime_clock.counter () in
let count = watch () |> Logs.on_error_msg ~use:(fun _ -> 0) in
Logs.app (fun m -> m "Watch completed for %d files in %a"
count Mtime.Span.pp (Mtime_clock.count c))
let () = main ()
(*---------------------------------------------------------------------------
Copyright (c) 2015 The bos programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)