From 73eef681e27803a1a7379be84ec74b17e02450fd Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 13 Dec 2010 21:54:56 +0000 Subject: [PATCH] Allow slave functions to have optional ?fail parameter for errors. --- slave.ml | 24 +++++++++++++----------- slave.mli | 35 ++++++++++++++++++++++++----------- 2 files changed, 37 insertions(+), 22 deletions(-) diff --git a/slave.ml b/slave.ml index 94fce75..74ce217 100644 --- 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 --- 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 -- 1.8.3.1