X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=ocaml%2Fexamples%2Fviewer.ml;h=eeff5252f738e6b7bb435cc95e4ba6497d960d62;hp=20fa608acf835ad30f140ff40fe6f69e83380035;hb=d37f69795396ec2354eb2d8480d64b9e5bdafacc;hpb=4c8bdd342450aad1f49a44a009eae015a44f9572

diff --git a/ocaml/examples/viewer.ml b/ocaml/examples/viewer.ml
index 20fa608..eeff525 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
  *
@@ -227,6 +228,7 @@ end = struct
 	*)
        debug "Slave.slave_loop: command failed";
 
+       !busy_cb `Idle;
        with_lock q_lock (fun () -> Q.clear q);
        GtkThread.async !failure_cb exn
     );
@@ -313,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 <domain/>" 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.(<domain..>_)) / .(<devices..>_)) / .(<disk..>_)) / }} in
+    let xs = {{ map xs with
+		| <source dev=(Latin1 & s) ..>_
+                | <source file=(Latin1 & s) ..>_ -> [s]
+                | _ -> [] }} in
+    {: xs :}
 end
 (* End of slave thread code. *)
 (*----------------------------------------------------------------------*)
@@ -383,7 +351,13 @@ type display_state = {
  * necessary to turn the exception into an error message.
  *)
 let failure ds exn =
-  debug "failure callback: %s" (Printexc.to_string exn)
+  let title = "Error" in
+  let msg = Printexc.to_string exn in
+  debug "failure callback: %s" msg;
+  let icon = GMisc.image () in
+  icon#set_stock `DIALOG_ERROR;
+  icon#set_icon_size `DIALOG;
+  GToolbox.message_box ~title ~icon msg
 
 (* This is called in the main thread when the slave thread transitions
  * to busy or idle.