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 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 () ->
   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
   )
 
       Cond.signal q_cond
   )
 


@@ -128,10 +128,11 @@ let discard_command_queue () =
       q_discard := true
   )
 
       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 -----*)
 
 
 (*----- Slave thread starts here -----*)
 


@@ -177,7 +178,7 @@ let rec loop () =
   debug "top of slave loop";
 
   (* Get the next command. *)
   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;
     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 ->
      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. *)
   );
 
   (* 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].
 
       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
 
 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. *)
 
 }
     (** 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
   (** [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
 
       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;
 
 type inspection_data = {
   insp_all_filesystems : (string * string) list;


@@ -103,7 +107,7 @@ and inspection_os = {
   insp_windows_systemroot : string option;
 }
 
   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
   (** [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})
       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
   (** [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}. *)
 
 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}. *)
 
 }
     (** 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.
   (** [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
       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
 
 val discard_command_queue : unit -> unit
   (** [discard_command_queue ()] discards any commands on the command