Allow slave functions to have optional ?fail parameter for errors.

diff --git a/slave.ml b/slave.ml
index 94fce75..74ce217 100644 (file)
--- a/slave.ml
+++ b/slave.ml
@@ -112,11 +112,11 @@ let q_lock = M.create ()
 let q_cond = Cond.create ()
 
 (* Send a command message to the slave thread. *)
-let send_to_slave cmd =
+let send_to_slave ?fail cmd =
   debug "sending message %s to slave thread ..." (string_of_command cmd);
   with_lock q_lock (
     fun () ->
-      Q.push cmd q;
+      Q.push (fail, cmd) q;
       Cond.signal q_cond
   )
 
@@ -128,10 +128,11 @@ let discard_command_queue () =
       q_discard := true
   )
 
-let connect uri cb = send_to_slave (Connect (uri, cb))
-let open_domain name cb = send_to_slave (Open_domain (name, cb))
-let open_images images cb = send_to_slave (Open_images (images, cb))
-let read_directory src path cb = send_to_slave (Read_directory (src, path, cb))
+let connect ?fail uri cb = send_to_slave ?fail (Connect (uri, cb))
+let open_domain ?fail name cb = send_to_slave ?fail (Open_domain (name, cb))
+let open_images ?fail images cb = send_to_slave ?fail (Open_images (images, cb))
+let read_directory ?fail src path cb =
+  send_to_slave ?fail (Read_directory (src, path, cb))
 
 (*----- Slave thread starts here -----*)
 
@@ -177,7 +178,7 @@ let rec loop () =
   debug "top of slave loop";
 
   (* Get the next command. *)
-  let cmd =
+  let fail, cmd =
     with_lock q_lock (
       fun () ->
         while Q.is_empty q do Cond.wait q_cond q_lock done;
@@ -191,11 +192,12 @@ let rec loop () =
      GtkThread.async !busy_hook ();
      execute_command cmd
    with exn ->
-     (* If a command or the callback fails, clear the command queue
-      * and run the failure hook in the main thread.
+     (* If the user provided an override ?fail parameter to the
+      * original call, call that, else call the global hook.
       *)
-     discard_command_queue ();
-     GtkThread.async !failure_hook exn
+     match fail with
+     | Some cb -> GtkThread.async cb exn
+     | None -> GtkThread.async !failure_hook exn
   );
 
   (* If there are no more commands in the queue, run the idle hook. *)

diff --git a/slave.mli b/slave.mli
index d36ef04..0df8466 100644 (file)
--- a/slave.mli
+++ b/slave.mli
@@ -54,9 +54,10 @@ type 'a callback = 'a -> unit
       list callback], and a command that returns nothing would have
       callback type [unit callback].
 
-      Note that errors are not returned this way.  Errors result
-      in the command queue being discarded and the failure_hook
-      function being called. *)
+      Note that errors are not returned this way.  Each function can
+      optionally supply an extra callback to handle errors, or if
+      not supplied then it defaults to the failure hook set by
+      {!set_failure_hook}. *)
 
 val no_callback : 'a callback
   (** The main thread uses this as a callback if it doesn't care about
@@ -69,7 +70,7 @@ type domain = {
 }
     (** List of domains as returned in the {!connect} callback. *)
 
-val connect : string option -> domain list callback -> unit
+val connect : ?fail:exn callback -> string option -> domain list callback -> unit
   (** [connect uri cb] causes the slave thread to disconnect from
       libvirt and connect to the libvirt [uri].  If this succeeds,
       then the list of all domains fetched from libvirt and [cb] is
@@ -77,7 +78,10 @@ val connect : string option -> domain list callback -> unit
 
       Although you can connect to remote hosts, libguestfs won't
       usually be able to see the drives on those hosts, so it normally
-      doesn't make sense to use remote URIs. *)
+      doesn't make sense to use remote URIs.
+
+      If [fail] is passed, then failures cause this callback to
+      be called.  If not, the global failure hook is called. *)
 
 type inspection_data = {
   insp_all_filesystems : (string * string) list;
@@ -103,7 +107,7 @@ and inspection_os = {
   insp_windows_systemroot : string option;
 }
 
-val open_domain : string -> inspection_data callback -> unit
+val open_domain : ?fail:exn callback -> string -> inspection_data callback -> unit
   (** [open_domain name cb] retrieves the list of block devices for
       the libvirt domain [name], creates a libguestfs handle, adds
       those block devices, launches the handle, and performs
@@ -113,11 +117,17 @@ val open_domain : string -> inspection_data callback -> unit
       with the list of filesystems and the results of inspection.
 
       The slave thread must be connected to libvirt (see {!connect})
-      else this command will fail. *)
+      else this command will fail.
+
+      If [fail] is passed, then failures cause this callback to
+      be called.  If not, the global failure hook is called. *)
 
-val open_images : string list -> inspection_data callback -> unit
+val open_images : ?fail:exn callback -> string list -> inspection_data callback -> unit
   (** [open_images images cb] is like {!open_domain} except
-      that it opens local disk image(s) directly. *)
+      that it opens local disk image(s) directly.
+
+      If [fail] is passed, then failures cause this callback to
+      be called.  If not, the global failure hook is called. *)
 
 type source = OS of inspection_os | Volume of string
   (** Source type used by {!read_directory}. *)
@@ -129,7 +139,7 @@ type direntry = {
 }
     (** Directory entry returned by {!read_directory}. *)
 
-val read_directory : source -> string -> direntry list callback -> unit
+val read_directory : ?fail:exn callback -> source -> string -> direntry list callback -> unit
   (** [read_directory src dir cb] reads the contents of the directory
       [dir] from source [src], and calls the callback function [cb]
       with the resulting list of directory entries, if successful.
@@ -138,7 +148,10 @@ val read_directory : source -> string -> direntry list callback -> unit
       dev]), or a fully mounted up operating system (if [src] is [OS ...]).
       In the second case all the mountpoints of the operating system
       are mounted up so that the path may span mountpoints in the
-      natural way. *)
+      natural way.
+
+      If [fail] is passed, then failures cause this callback to
+      be called.  If not, the global failure hook is called. *)
 
 val discard_command_queue : unit -> unit
   (** [discard_command_queue ()] discards any commands on the command