7:56 a.m.
Similar to the previous commit, this creates a new Visit.Failure
exception for the visit function, avoiding Warning 52.
---
common/mlvisit/visit-c.c | 6 ++++--
common/mlvisit/visit.ml | 5 +++++
common/mlvisit/visit.mli | 6 ++++--
common/mlvisit/visit_tests.ml | 10 ++++++----
4 files changed, 19 insertions(+), 8 deletions(-)
diff --git a/common/mlvisit/visit-c.c b/common/mlvisit/visit-c.c
index fcd0428f7..7137c4998 100644
--- a/common/mlvisit/visit-c.c
+++ b/common/mlvisit/visit-c.c
@@ -53,6 +53,7 @@ value
guestfs_int_mllib_visit (value gv, value dirv, value fv)
{
CAMLparam3 (gv, dirv, fv);
+ value *visit_failure_exn;
guestfs_h *g = (guestfs_h *) (intptr_t) Int64_val (gv);
struct visitor_function_wrapper_args args;
/* The dir string could move around when we call the
@@ -81,9 +82,10 @@ guestfs_int_mllib_visit (value gv, value dirv, value fv)
/* Otherwise it's some other failure. The visit function has
* already printed the error to stderr (XXX - fix), so we raise a
- * generic Failure.
+ * generic exception.
*/
- caml_failwith ("visit");
+ visit_failure_exn = caml_named_value ("Visit.Failure");
+ caml_raise (*visit_failure_exn);
}
free (dir);
diff --git a/common/mlvisit/visit.ml b/common/mlvisit/visit.ml
index da2e122ed..4e664f049 100644
--- a/common/mlvisit/visit.ml
+++ b/common/mlvisit/visit.ml
@@ -18,8 +18,13 @@
type visitor_function = string -> string option -> Guestfs.statns ->
Guestfs.xattr array -> unit
+exception Failure
+
external c_visit : int64 -> string -> visitor_function -> unit =
"guestfs_int_mllib_visit"
let visit g dir f =
c_visit (Guestfs.c_pointer g) dir f
+
+let () =
+ Callback.register_exception "Visit.Failure" Failure
diff --git a/common/mlvisit/visit.mli b/common/mlvisit/visit.mli
index cba85785e..85a204937 100644
--- a/common/mlvisit/visit.mli
+++ b/common/mlvisit/visit.mli
@@ -36,6 +36,8 @@ type visitor_function = string -> string option -> Guestfs.statns
-> Guestfs.xat
The visitor callback may raise an exception, which will cause
the whole visit to fail with an error (raising the same exception). *)
+exception Failure
+
val visit : Guestfs.t -> string -> visitor_function -> unit
(** [visit g dir f] calls the [visitor_function f] once for
every directory and every file.
@@ -43,8 +45,8 @@ val visit : Guestfs.t -> string -> visitor_function -> unit
If the visitor function raises an exception, then the whole visit
stops and raises the same exception.
- Also other errors can happen, and those will cause a [Failure
- "visit"] exception to be raised. (Because of the implementation
+ Also other errors can happen, and those will cause a {!Failure}
+ exception to be raised. (Because of the implementation
of the underlying function, the real error is printed
unconditionally to stderr).
diff --git a/common/mlvisit/visit_tests.ml b/common/mlvisit/visit_tests.ml
index 6753dfb90..30a1669a8 100644
--- a/common/mlvisit/visit_tests.ml
+++ b/common/mlvisit/visit_tests.ml
@@ -25,6 +25,8 @@ open Visit
module G = Guestfs
+exception Test of string
+
let rec main () =
let g = new G.guestfs () in
g#add_drive_scratch (Int64.mul 1024L (Int64.mul 1024L 1024L));
@@ -107,17 +109,17 @@ let rec main () =
(* Raise an exception in the visitor_function. *)
printf "testing exception in visitor function\n%!";
- (try visit g#ocaml_handle "/" (fun _ _ _ _ -> invalid_arg
"test");
+ (try visit g#ocaml_handle "/" (fun _ _ _ _ -> raise (Test
"test"));
assert false
- with Invalid_argument "test" -> ()
+ with Test "test" -> ()
(* any other exception escapes and kills the test *)
);
- (* Force an error and check [Failure "visit"] is raised. *)
+ (* Force an error and check [Visit.Failure] is raised. *)
printf "testing general error in visit\n%!";
(try visit g#ocaml_handle "/nosuchdir" (fun _ _ _ _ -> ());
assert false
- with Failure "visit" -> ()
+ with Visit.Failure -> ()
(* any other exception escapes and kills the test *)
);
--
2.13.2