[Libguestfs] [PATCH 6/9] ocaml: Avoid Warning 52 for Visit.visit function.

[Richard W.M. Jones]

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