X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=ocaml%2Fexamples%2Fviewer.ml;h=6cd465abc16566fc5654f3df33d12d7eed7c6b3b;hb=4f4880303693bc2e55ce431e87302098654b7f03;hp=ef6627b1b92a4fff7d4fa1fa4aca63eeffc05ece;hpb=d278ef8ad9090441a713c7334804199318aeb3e1;p=libguestfs.git
diff --git a/ocaml/examples/viewer.ml b/ocaml/examples/viewer.ml
index ef6627b..6cd465a 100644
--- a/ocaml/examples/viewer.ml
+++ b/ocaml/examples/viewer.ml
@@ -10,6 +10,7 @@
* - extlib (http://code.google.com/p/ocaml-extlib/)
* - lablgtk2 (http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html
* - xml-light (http://tech.motion-twin.com/xmllight.html)
+ * - cduce and ocamlduce (http://cduce.org/)
* - ocaml-libvirt (http://libvirt.org/ocaml)
* - ocaml-libguestfs
*
@@ -62,7 +63,7 @@ module G = Guestfs
module M = Mutex
module Q = Queue
-let verbose = ref false (* Verbose mode. *)
+let verbose = ref false (* Verbose mode. *)
let debug fs =
let f str = if !verbose then ( prerr_string str; prerr_newline () ) in
@@ -77,9 +78,9 @@ module Slave : sig
type 'a callback = 'a -> unit
type partinfo = {
- pt_name : string; (** device / LV name *)
- pt_size : int64; (** in bytes *)
- pt_content : string; (** the output of the 'file' command *)
+ pt_name : string; (** device / LV name *)
+ pt_size : int64; (** in bytes *)
+ pt_content : string; (** the output of the 'file' command *)
pt_statvfs : G.statvfs option; (** None if not mountable *)
}
@@ -88,33 +89,33 @@ module Slave : sig
val set_failure_callback : exn callback -> unit
(** Set the function that is called in the main thread whenever
- there is a command failure in the slave. The command queue
- is cleared before this is sent. [exn] is the exception
- associated with the failure. *)
+ there is a command failure in the slave. The command queue
+ is cleared before this is sent. [exn] is the exception
+ associated with the failure. *)
val set_busy_callback : [`Busy|`Idle] callback -> unit
(** Set the function that is called in the main thread whenever
- the slave thread goes busy or idle. *)
+ the slave thread goes busy or idle. *)
val exit_thread : unit -> unit
(** [exit_thread ()] causes the slave thread to exit. *)
val connect : string option -> string option callback -> unit
(** [connect uri cb] connects to libvirt [uri], and calls [cb]
- if it completes successfully. Any previous connection is
- automatically cleaned up and disconnected. *)
+ if it completes successfully. Any previous connection is
+ automatically cleaned up and disconnected. *)
val get_domains : string list callback -> unit
(** [get_domains cb] gets the list of active domains from libvirt,
- and calls [cb domains] with the names of those domains. *)
+ and calls [cb domains] with the names of those domains. *)
val open_domain : string -> partinfo list callback -> unit
(** [open_domain dom cb] sets the domain [dom] as the current
- domain, and launches a libguestfs handle for it. Any previously
- current domain and libguestfs handle is closed. Once the
- libguestfs handle is opened (which usually takes some time),
- callback [cb] is called with the list of partitions found
- in the guest. *)
+ domain, and launches a libguestfs handle for it. Any previously
+ current domain and libguestfs handle is closed. Once the
+ libguestfs handle is opened (which usually takes some time),
+ callback [cb] is called with the list of partitions found
+ in the guest. *)
val slave_loop : unit -> unit
(** The slave thread's main loop, running in the slave thread. *)
@@ -167,7 +168,7 @@ end = struct
| Either r -> r
| Or exn -> raise exn
- let q = Q.create () (* queue of commands *)
+ let q = Q.create () (* queue of commands *)
let q_lock = M.create ()
let q_cond = Cd.create ()
@@ -176,8 +177,8 @@ end = struct
debug "sending to slave: %s" (string_of_command c);
with_lock q_lock (
fun () ->
- Q.push c q;
- Cd.signal q_cond
+ Q.push c q;
+ Cd.signal q_cond
)
let exit_thread () =
@@ -197,9 +198,9 @@ end = struct
* any references to these objects to escape from the slave
* thread.
*)
- let conn = ref None (* libvirt connection *)
- let dom = ref None (* libvirt domain *)
- let g = ref None (* libguestfs handle *)
+ let conn = ref None (* libvirt connection *)
+ let dom = ref None (* libvirt domain *)
+ let g = ref None (* libguestfs handle *)
let quit = ref false
@@ -207,11 +208,11 @@ end = struct
debug "Slave.slave_loop: waiting for a command";
let c =
with_lock q_lock (
- fun () ->
- while Q.is_empty q do
- Cd.wait q_cond q_lock
- done;
- Q.pop q
+ fun () ->
+ while Q.is_empty q do
+ Cd.wait q_cond q_lock
+ done;
+ Q.pop q
) in
(try
@@ -222,9 +223,9 @@ end = struct
debug "Slave.slave_loop: command succeeded";
with exn ->
(* If an exception is thrown, it means the command failed. In
- * this case we clear the command queue and deliver the failure
- * callback in the main thread.
- *)
+ * this case we clear the command queue and deliver the failure
+ * callback in the main thread.
+ *)
debug "Slave.slave_loop: command failed";
!busy_cb `Idle;
@@ -237,69 +238,69 @@ end = struct
and exec_command = function
| Exit_thread ->
- quit := true; (* quit first in case disconnect_all throws an exn *)
- disconnect_all ()
+ quit := true; (* quit first in case disconnect_all throws an exn *)
+ disconnect_all ()
| Connect (name, cb) ->
- disconnect_all ();
- conn := Some (C.connect_readonly ?name ());
- cb name
+ disconnect_all ();
+ conn := Some (C.connect_readonly ?name ());
+ cb name
| Get_domains cb ->
- let conn = Option.get !conn in
- let doms = D.get_domains conn [D.ListAll] in
- (* Only return the names, so that the libvirt objects
- * aren't leaked outside the slave thread.
- *)
- let doms = List.map D.get_name doms in
- cb doms
+ let conn = Option.get !conn in
+ let doms = D.get_domains conn [D.ListAll] in
+ (* Only return the names, so that the libvirt objects
+ * aren't leaked outside the slave thread.
+ *)
+ let doms = List.map D.get_name doms in
+ cb doms
| Open_domain (domname, cb) ->
- let conn = Option.get !conn in
- disconnect_dom ();
- dom := Some (D.lookup_by_name conn domname);
- let dom = Option.get !dom in
-
- (* Get the devices. *)
- let xml = D.get_xml_desc dom in
- let devs = get_devices_from_xml xml in
-
- (* Create the libguestfs handle and launch it. *)
- let g' = G.create () in
- List.iter (G.add_drive_ro g') devs;
- G.launch g';
- g := Some g';
-
- (* Get the list of partitions. *)
- let parts = Array.to_list (G.list_partitions g') in
- (* Remove any which are PVs. *)
- let pvs = Array.to_list (G.pvs g') in
- let parts = List.filter (fun part -> not (List.mem part pvs)) parts in
- let lvs = Array.to_list (G.lvs g') in
- let parts = parts @ lvs in
-
- let parts = List.map (
- fun part ->
- (* Find out the size of each partition. *)
- let size = G.blockdev_getsize64 g' part in
-
- (* Find out what's on each partition. *)
- let content = G.file g' part in
-
- (* Try to mount it. *)
- let statvfs =
- try
- G.mount_ro g' part "/";
- Some (G.statvfs g' "/")
- with _ -> None in
- G.umount_all g';
-
- { pt_name = part; pt_size = size; pt_content = content;
- pt_statvfs = statvfs }
- ) parts in
-
- (* Call the callback. *)
- cb parts
+ let conn = Option.get !conn in
+ disconnect_dom ();
+ dom := Some (D.lookup_by_name conn domname);
+ let dom = Option.get !dom in
+
+ (* Get the devices. *)
+ let xml = D.get_xml_desc dom in
+ let devs = get_devices_from_xml xml in
+
+ (* Create the libguestfs handle and launch it. *)
+ let g' = G.create () in
+ List.iter (G.add_drive_ro g') devs;
+ G.launch g';
+ g := Some g';
+
+ (* Get the list of partitions. *)
+ let parts = Array.to_list (G.list_partitions g') in
+ (* Remove any which are PVs. *)
+ let pvs = Array.to_list (G.pvs g') in
+ let parts = List.filter (fun part -> not (List.mem part pvs)) parts in
+ let lvs = Array.to_list (G.lvs g') in
+ let parts = parts @ lvs in
+
+ let parts = List.map (
+ fun part ->
+ (* Find out the size of each partition. *)
+ let size = G.blockdev_getsize64 g' part in
+
+ (* Find out what's on each partition. *)
+ let content = G.file g' part in
+
+ (* Try to mount it. *)
+ let statvfs =
+ try
+ G.mount_ro g' part "/";
+ Some (G.statvfs g' "/")
+ with _ -> None in
+ G.umount_all g';
+
+ { pt_name = part; pt_size = size; pt_content = content;
+ pt_statvfs = statvfs }
+ ) parts in
+
+ (* Call the callback. *)
+ cb parts
(* Close all libvirt/libguestfs handles. *)
and disconnect_all () =
@@ -314,52 +315,18 @@ end = struct
(match !dom with Some dom -> D.free dom | None -> ());
dom := None
- (* This would be much simpler if OCaml had either a decent XPath
- * implementation, or if ocamlduce was stable enough that we
- * could rely on it being available. So this is *not* an example
- * of either good OCaml or good programming. XXX
- *)
and get_devices_from_xml xml =
- let xml = Xml.parse_string xml in
- let devices =
- match xml with
- | Xml.Element ("domain", _, children) ->
- let devices =
- List.filter_map (
- function
- | Xml.Element ("devices", _, devices) -> Some devices
- | _ -> None
- ) children in
- List.concat devices
- | _ ->
- failwith "get_xml_desc didn't return " in
- let rec source_dev_of = function
- | [] -> None
- | Xml.Element ("source", attrs, _) :: rest ->
- (try Some (List.assoc "dev" attrs)
- with Not_found -> source_dev_of rest)
- | _ :: rest -> source_dev_of rest
- in
- let rec source_file_of = function
- | [] -> None
- | Xml.Element ("source", attrs, _) :: rest ->
- (try Some (List.assoc "file" attrs)
- with Not_found -> source_file_of rest)
- | _ :: rest -> source_file_of rest
- in
- let devs =
- List.filter_map (
- function
- | Xml.Element ("disk", _, children) -> source_dev_of children
- | _ -> None
- ) devices in
- let files =
- List.filter_map (
- function
- | Xml.Element ("disk", _, children) -> source_file_of children
- | _ -> None
- ) devices in
- devs @ files
+ (* Lengthy discussion of the merits or otherwise of this code here:
+ * http://groups.google.com/group/fa.caml/browse_thread/thread/48e05d49b0f21b8a/5296bceb31ebfff3
+ *)
+ let xml = Xmllight_loader.from_string xml in
+ let xs = {{ [xml] }} in
+ let xs = {{ (((xs.(_)) / .(_)) / .(_)) / }} in
+ let xs = {{ map xs with
+ |