* - 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
*
*)
debug "Slave.slave_loop: command failed";
+ !busy_cb `Idle;
with_lock q_lock (fun () -> Q.clear q);
GtkThread.async !failure_cb exn
);
(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. *)
(*----------------------------------------------------------------------*)
* 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.