+ (* Turn it into XML data. *)
+ let caps = Xml.parse_string caps in
+ eprintf "capabilities:\n%s\n%!" (Xml.to_string_fmt caps);
+
+ (* We're looking for a guest with <os_type>hvm</os_type>
+ * and <arch name="target-arch">... Later when we can
+ * install PV drivers automatically, we will want to look
+ * for paravirt guest types too.
+ *)
+ let guests = children_with_name "guest" caps in
+ let guests =
+ List.filter (xml_has_pcdata_child "os_type" "hvm") guests in
+ let arch_str = string_of_architecture config_target.tgt_architecture in
+ let guests =
+ List.filter (
+ xml_has_child_matching (
+ function
+ | Xml.Element (n, attribs, _)
+ when n = "arch"
+ && List.exists (
+ fun (n, a) ->
+ n = "name" &&
+ (* deal with i386 vs i686 pestilence *)
+ architecture_of_string a = config_target.tgt_architecture
+ ) attribs
+ -> true
+ | _ -> false
+ )
+ ) guests in
+
+ (* In theory at this point we only have a single guest type
+ * remaining. It might be that we have _zero_ available
+ * guest types, which indicates probably an unsupported
+ * capability of the remote hypervisor (or just that one of
+ * many parsing or heuristics failed). It might be that
+ * we have > 1 available guest types, which indicates some
+ * feature we don't know about.
+ *)
+ let len = List.length guests in
+ if len = 0 then (
+ message_box "Warning"
+ (sprintf "Remote hypervisor claims not to support fully virtualized %s guests.\n\nContinuing anyway.\n\n%!" arch_str);
+ raise Not_found
+ );
+
+ if len > 1 then (
+ message_box "Note"
+ (sprintf "Remote hypervisor supports multiple types of fully virtualized %s guests.\n\nPlease help further development of libvirt and virt-p2v by sending the file /tmp/virt-p2v.log back to the developers. See the main virt-p2v website for contact details." arch_str)
+ );
+
+ let guest = List.hd guests in
+
+ let os_type =
+ try Some (find_pcdata_child "os_type" guest)
+ with Not_found -> None in
+ let arch_section = find_child_with_name "arch" guest in
+ let emulator =
+ try Some (find_pcdata_child "emulator" arch_section)
+ with Not_found -> None in
+ let loader =
+ try Some (find_pcdata_child "loader" arch_section)
+ with Not_found -> None in
+ let machine =
+ try Some (find_pcdata_child "machine" arch_section)
+ with Not_found -> None in
+
+ os_type, emulator, loader, machine