+ (* If architecture is set to UnknownArch, then assume the same
+ * architecture as the live CD.
+ *)
+ let config_target =
+ match config_target.tgt_architecture with
+ | UnknownArch ->
+ let arch = shget "uname -m" in
+ let arch =
+ match arch with
+ | Some (arch :: _) -> architecture_of_string arch
+ | _ -> I386 (* probably wrong XXX *) in
+ { config_target with tgt_architecture = arch }
+ | _ -> config_target in
+
+ (* Try to get the capabilities from the remote machine. If we fail
+ * it doesn't matter too much.
+ *)
+ let caps_os_type, caps_emulator, caps_loader, caps_machine =
+ try
+ if not config_target.tgt_libvirtd then raise Not_found;
+
+ let proto, path =
+ match config_target.tgt_hypervisor with
+ | Some Xen -> "xen", "/"
+ | Some (QEMU|KVM) -> "qemu", "/system"
+ | None -> raise Not_found in
+ let name =
+ sprintf "%s+ssh://%s@%s:%s%s"
+ proto config_ssh.ssh_username
+ config_ssh.ssh_host config_ssh.ssh_port path in
+ eprintf "capabilities URI = %S\n%!" name;
+
+ print_endline (s_ "Try to fetch remote hypervisor capabilities ...\n");
+
+ let conn = Libvirt.Connect.connect_readonly ~name () in
+ let caps = Libvirt.Connect.get_capabilities conn in
+ Libvirt.Connect.close conn;
+
+ (* 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 (s_ "Warning")
+ (sprintf (f_ "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 (s_ "Note")
+ (sprintf (f_ "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
+ with
+ | Not_found -> None, None, None, None
+ | Xml.Error err ->
+ eprintf "XML error: %s\n%!" (Xml.error err);
+ None, None, None, None
+ | Xml.Not_element _ | Xml.Not_pcdata _ | Xml.No_attribute _ ->
+ (* If these occur, need to add some more debugging. *)
+ eprintf "XML error when parsing capabilities\n%!";
+ None, None, None, None
+ | Libvirt.Virterror err ->
+ eprintf "libvirt error: %s\n%!" (Libvirt.Virterror.to_string err);
+ None, None, None, None
+ | Invalid_argument str ->
+ eprintf "libvirt error: %s\n%!" str;
+ None, None, None, None in
+
+ (* In test mode, exit here before we do Bad Things to the developer's