Parse dmesg to get more accurate memory.

[virt-p2v.git] / virt-p2v

diff --git a/virt-p2v b/virt-p2v
index 3df66f3..922ad40 100755 (executable)
--- a/virt-p2v
+++ b/virt-p2v
@@ -51,6 +51,14 @@ type architecture =
   | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
   | OtherArch of string
   | UnknownArch
   | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
   | OtherArch of string
   | UnknownArch

+type target_config = {
+  tgt_hypervisor : hypervisor option;  (* Remote hypervisor. *)
+  tgt_architecture : architecture;     (* Remote architecture. *)
+  tgt_memory : int;                    (* Memory (megabytes). *)
+  tgt_vcpus : int;                     (* Number of virtual CPUs. *)
+  tgt_mac_address : string;            (* MAC address. *)
+  tgt_libvirtd : bool;                 (* True if libvirtd on remote. *)
+}

 
 (*----------------------------------------------------------------------*)
 (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
 
 (*----------------------------------------------------------------------*)
 (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.


@@ -87,12 +95,7 @@ let config_devices_to_send = ref None
 let config_root_filesystem = ref None
 
 (* Configuration of the target. *)
 let config_root_filesystem = ref None
 
 (* Configuration of the target. *)

-let config_hypervisor = ref None
-let config_architecture = ref None
-let config_memory = ref None
-let config_vcpus = ref None
-let config_mac_address = ref None
-let config_libvirtd = ref None
+let config_target = ref None

 
 (* The name of the program as displayed in various places. *)
 let program_name = "virt-p2v"
 
 (* The name of the program as displayed in various places. *)
 let program_name = "virt-p2v"


@@ -114,6 +117,8 @@ let test_dialog_stages = false
 #load "mlnewt.cma";;
 #directory "+xml-light";;
 #load "xml-light.cma";;
 #load "mlnewt.cma";;
 #directory "+xml-light";;
 #load "xml-light.cma";;

+#directory "+libvirt";;
+#load "mllibvirt.cma";;

 
 open Unix
 open Printf
 
 open Unix
 open Printf


@@ -240,6 +245,101 @@ let failwith text =
   message_box "Error" text;
   exit 1
 
   message_box "Error" text;
   exit 1
 

+(* Display a dialog with checkboxes, return the multiple selected items. *)
+let select_multiple ?stage ?(force_one = false) width title items =
+  with_newt (
+    fun () ->
+      open_centered_window ?stage width 20 title;
+
+      let entries =
+       List.mapi (
+         fun i (label, handle, selected) ->
+           let cb =
+             Newt.checkbox 1 (i+1) label
+               (if selected then '*' else ' ') None in
+           (handle, cb)
+       ) items in
+
+      let ok = Newt.button 48 16 "  OK  " in
+
+      let vb =
+       if List.length entries > 10 then
+         Some (Newt.vertical_scrollbar 58 1 10
+                 Newt_int.NEWT_COLORSET_WINDOW
+                 Newt_int.NEWT_COLORSET_ACTCHECKBOX)
+       else
+         None in
+      let form = Newt.form vb None [] in
+      Newt.form_add_components form (List.map snd entries);
+      Newt.form_add_component form ok;
+
+      let selected =
+       let rec loop () =
+         ignore (Newt.run_form form);
+         let selected = List.filter_map (
+           fun (handle, cb) ->
+             if Newt.checkbox_get_value cb = '*' then Some handle else None
+         ) entries in
+         if force_one && selected = [] then loop ()
+         else selected
+       in
+       loop () in
+
+      Newt.pop_window ();
+
+      selected
+  )
+
+(* Display a dialog with radio buttons, return the single selected item. *)
+let select_single ?stage width title items =
+  if items = [] then failwith "select_single: no items";
+
+  with_newt (
+    fun () ->
+      open_centered_window ?stage width 20 title;
+
+      let prev = ref None in
+      let entries =
+       List.mapi (
+         fun i (label, handle) ->
+           let rb = Newt.radio_button 1 (i+1) label (!prev = None) !prev in
+           prev := Some rb;
+           (handle, rb)
+       ) items in
+
+      let ok = Newt.button (width-12) 16 "  OK  " in
+
+      let vb =
+       if List.length entries > 10 then
+         Some (Newt.vertical_scrollbar 58 1 10
+                 Newt_int.NEWT_COLORSET_WINDOW
+                 Newt_int.NEWT_COLORSET_ACTCHECKBOX)
+       else
+         None in
+      let form = Newt.form vb None [] in
+      Newt.form_add_components form (List.map snd entries);
+      Newt.form_add_component form ok;
+
+      let (selected, _) =
+       let rec loop () =
+         ignore (Newt.run_form form);
+         let r = Option.get !prev in
+         let r = Newt.radio_get_current r in
+         (* Now we compare 'r' to all the 'rb's in the list
+          * to see which one is selected.
+          *)
+         try
+           List.find (fun (_, rb) -> Newt.component_equals r rb) entries
+         with
+           Not_found -> loop ()
+       in
+       loop () in
+
+      Newt.pop_window ();
+
+      selected
+  )
+

 (* Shell-safe quoting function.  In fact there's one in stdlib so use it. *)
 let quote = Filename.quote
 
 (* Shell-safe quoting function.  In fact there's one in stdlib so use it. *)
 let quote = Filename.quote
 


@@ -404,6 +504,7 @@ let auto_network () =
 
   (* NB. Lazy unmount is required because dhclient keeps its current
    * directory open on /etc/sysconfig/network-scripts/
 
   (* NB. Lazy unmount is required because dhclient keeps its current
    * directory open on /etc/sysconfig/network-scripts/

+   * (Fixed in dhcp >= 4.0.0 but be generous anyway).

    *)
   sh "mount -o bind /mnt/root/etc /etc";
   let status = shwithstatus "/etc/init.d/network start" in
    *)
   sh "mount -o bind /mnt/root/etc /etc";
   let status = shwithstatus "/etc/init.d/network start" in


@@ -480,9 +581,17 @@ let ssh_disconnect (_, chan) =
   | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
   | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
 
   | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
   | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
 

+(* Use these functions to upload a file. *)
+let ssh_start_upload config filename =
+  let cmd =
+    sprintf "cat \\> %s/%s" (quote config.ssh_directory) (quote filename) in
+  ssh_connect config cmd
+
+let ssh_finish_upload = ssh_disconnect
+

 (* Test SSH connection. *)
 let test_ssh config =
 (* Test SSH connection. *)
 let test_ssh config =

-  printf "Testing SSH connection.\n\n%!";
+  printf "Testing SSH connection by listing files in remote directory ...\n\n%!";

 
   let cmd = sprintf "/bin/ls %s" (quote config.ssh_directory) in
   let conn = ssh_connect config cmd in
 
   let cmd = sprintf "/bin/ls %s" (quote config.ssh_directory) in
   let conn = ssh_connect config cmd in


@@ -499,7 +608,7 @@ let test_ssh config =
     true
 
 (* Rewrite /mnt/root/etc/fstab. *)
     true
 
 (* Rewrite /mnt/root/etc/fstab. *)

-let rewrite_fstab state devices_to_send =
+let rewrite_fstab devices_to_send =

   let filename = "/mnt/root/etc/fstab" in
   if is_file filename = Some true then (
     sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
   let filename = "/mnt/root/etc/fstab" in
   if is_file filename = Some true then (
     sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));


@@ -829,10 +938,32 @@ let rec main ttyname =
 
   (* Autodetect system memory. *)
   let system_memory =
 
   (* Autodetect system memory. *)
   let system_memory =

-    let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
-    match mem with
-    | Some (mem::_) -> int_of_float (float_of_string mem)
-    | _ -> 256 in
+    (* Try to parse dmesg first to find the 'Memory:' report when
+     * the kernel booted.  If available, this can give us an
+     * indication of usable RAM on this system.
+     *)
+    let dmesg = shget "dmesg" in
+    try
+      let dmesg =
+       match dmesg with Some lines -> lines | None -> raise Not_found in
+      let line =
+       List.find (fun line -> String.starts_with line "Memory: ") dmesg in
+      let subs = Pcre.exec ~pat:"k/([[:digit:]]+)k available" line in
+      let mem = Pcre.get_substring subs 1 in
+      int_of_string mem / 1024
+    with
+      Not_found | Failure "int_of_string" ->
+       (* 'dmesg' can't be parsed.  The backup plan is to look
+        * at /proc/meminfo.
+        *)
+       let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
+       match mem with
+       | Some (mem::_) -> int_of_float (float_of_string mem)
+
+       (* For some reason even /proc/meminfo didn't work.  Just
+        * assume 256 MB instead.
+        *)
+       | _ -> 256 in

 
   (* Autodetect system # pCPUs. *)
   let system_nr_cpus =
 
   (* Autodetect system # pCPUs. *)
   let system_nr_cpus =


@@ -857,34 +988,14 @@ let rec main ttyname =
          match !config_transfer_type with
          | Some t -> t
          | None ->
          match !config_transfer_type with
          | Some t -> t
          | None ->

-             open_centered_window ~stage:"Transfer type"
-               40 10 "Transfer type";
-
-             let p2v =
-               Newt.radio_button 1 1 "Physical to virtual (P2V)" true
-                 None in
-             let v2v =
-               Newt.radio_button 1 2 "Virtual to virtual (V2V)" false
-                 (Some p2v) in
-             let ok = Newt.button 28 6 "  OK  " in
-
-             let form = Newt.form None None [] in
-             Newt.form_add_components form [p2v; v2v; ok];
+             let items = [
+               "Physical to Virtual (P2V)", P2V;
+               "Virtual to Virtual (V2V)", V2V;
+             ] in

 
 

-             let t =
-               let rec loop () =
-                 ignore (Newt.run_form form);
-
-                 let r = Newt.radio_get_current p2v in
-                 if Newt.component_equals r p2v then P2V
-                 else if Newt.component_equals r v2v then V2V
-                 else loop ()
-               in
-               loop () in
-
-             Newt.pop_window ();
-
-             t in
+             select_single ~stage:"Transfer type" 40
+               "Transfer type"
+               items in

 
        (* Network configuration. *)
        let config_network =
 
        (* Network configuration. *)
        let config_network =


@@ -901,8 +1012,6 @@ let rec main ttyname =
               * root partitions found which allow us to do
               * automatic configuration in a known way.
               *)
               * root partitions found which allow us to do
               * automatic configuration in a known way.
               *)

-             let partition_map = Hashtbl.create 13 in
-             let maplen = ref 1 in

              let rec loop = function
                | [] -> ()
                | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
              let rec loop = function
                | [] -> ()
                | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))


@@ -911,11 +1020,7 @@ let rec main ttyname =
                      sprintf "%s (%s)"
                        (dev_of_partition partition)
                        (string_of_linux_distro distro) in
                      sprintf "%s (%s)"
                        (dev_of_partition partition)
                        (string_of_linux_distro distro) in

-                   Hashtbl.add partition_map (!maplen) partition;
-                   ignore (
-                     Newt.listbox_append_entry autolist label (!maplen)
-                   );
-                   incr maplen;
+                   ignore (Newt.listbox_append_entry autolist label partition);

                    loop parts
                | _ :: parts -> loop parts
              in
                    loop parts
                | _ :: parts -> loop parts
              in


@@ -924,7 +1029,7 @@ let rec main ttyname =
              (* If there is no suitable root partition (the listbox
               * is empty) then disable the auto option and the listbox.
               *)
              (* If there is no suitable root partition (the listbox
               * is empty) then disable the auto option and the listbox.
               *)

-             let no_auto = Hashtbl.length partition_map = 0 in
+             let no_auto = Newt.listbox_item_count autolist = 0 in

 
              let auto =
                Newt.radio_button 1 1
 
              let auto =
                Newt.radio_button 1 1


@@ -935,7 +1040,8 @@ let rec main ttyname =
 
              if no_auto then (
                Newt.component_takes_focus auto false;
 
              if no_auto then (
                Newt.component_takes_focus auto false;

-               Newt.component_takes_focus autolist false
+               Newt.component_takes_focus
+                 (Newt.component_of_listbox autolist) false

              );
 
              let qemu =
              );
 
              let qemu =


@@ -977,10 +1083,12 @@ let rec main ttyname =
              in
 
              let enable_autolist () =
              in
 
              let enable_autolist () =

-               Newt.component_takes_focus autolist true
+               Newt.component_takes_focus
+                 (Newt.component_of_listbox autolist) true

              in
              let disable_autolist () =
              in
              let disable_autolist () =

-               Newt.component_takes_focus autolist false
+               Newt.component_takes_focus
+                 (Newt.component_of_listbox autolist) false

              in
 
              disable_static ();
              in
 
              disable_static ();


@@ -998,7 +1106,8 @@ let rec main ttyname =
              let ok = Newt.button 48 16 "  OK  " in
 
              let form = Newt.form None None [] in
              let ok = Newt.button 48 16 "  OK  " in
 
              let form = Newt.form None None [] in

-             Newt.form_add_components form [auto; autolist;
+             Newt.form_add_components form [auto;
+                                            Newt.component_of_listbox autolist;

                                             shell;qemu;nonet;static;
                                             label1;label2;label3;label4;label5;
                                             entry1;entry2;entry3;entry4;entry5;
                                             shell;qemu;nonet;static;
                                             label1;label2;label3;label4;label5;
                                             entry1;entry2;entry3;entry4;entry5;


@@ -1012,7 +1121,7 @@ let rec main ttyname =
                  if Newt.component_equals r auto then (
                    match Newt.listbox_get_current autolist with
                    | None -> loop ()
                  if Newt.component_equals r auto then (
                    match Newt.listbox_get_current autolist with
                    | None -> loop ()

-                   | Some i -> Auto (Hashtbl.find partition_map i)
+                   | Some part -> Auto part

                  )
                  else if Newt.component_equals r shell then Shell
                  else if Newt.component_equals r qemu then QEMUUserNet
                  )
                  else if Newt.component_equals r shell then Shell
                  else if Newt.component_equals r qemu then QEMUUserNet


@@ -1150,260 +1259,172 @@ let rec main ttyname =
     if not (test_ssh config_ssh) then
       failwith "SSH configuration failed";
 
     if not (test_ssh config_ssh) then
       failwith "SSH configuration failed";
 

-(*
-
-  let ask_devices state =
-    let selected_devices = Option.default [] state.devices_to_send in
-    let devices = List.map (
-      fun (dev, blksize) ->
-       (dev,
-        sprintf "/dev/%s (%.3f GB)" dev
-          ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
-        List.mem dev selected_devices)
-    ) all_block_devices in
-    match
-    checklist "Devices" "Pick devices to send" 15 50 8 devices
-    with
-    | Yes [] | No | Help | Error -> Ask_again
-    | Yes devices -> Next { state with devices_to_send = Some devices }
-    | Back -> Prev
-  in
-
-  let ask_root state =
-    let parts = List.mapi (
-      fun i (part, nature) ->
-       let descr =
-         match nature with
-         | LinuxSwap -> " (Linux swap)"
-         | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
-         | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
-         | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
-         | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
-         | WindowsRoot -> " (Windows C:)"
-         | LinuxBoot -> " (Linux /boot)"
-         | NotRoot -> " (filesystem)"
-         | UnknownNature -> "" in
-       (string_of_int i,
-        dev_of_partition part ^ descr,
-        Some part = state.root_filesystem)
-    ) all_partitions in
-    match
-    radiolist "Root device"
-      "Pick partition containing the root (/) filesystem" 18 70 9
-      parts
-    with
-    | Yes (i::_) ->
-       let (part, _) = List.nth all_partitions (int_of_string i) in
-       Next { state with root_filesystem = Some part }
-    | Yes [] | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+  (* Devices and root partition and target configuration selection stage. *)
+  let config_devices_to_send, config_root_filesystem, config_target =
+    with_newt (
+      fun () ->
+       let config_devices_to_send =
+         match !config_devices_to_send with
+         | Some ds -> ds
+         | None ->
+             let items = List.map (
+                 fun (dev, size) ->
+                   let label =
+                     sprintf "/dev/%s (%.3f GB)" dev
+                     ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
+                   (label, dev, true)
+             ) all_block_devices in
+
+             select_multiple ~stage:"Block devices" ~force_one:true 60
+               "Select block devices to send"
+               items in
+
+       let config_root_filesystem =
+         match !config_root_filesystem with
+         | Some fs -> fs
+         | None ->
+             let items = List.map (
+               fun (part, nature) ->
+                 let label =
+                   sprintf "%s %s" (dev_of_partition part)
+                     (string_of_nature nature) in
+                 (label, part)
+             ) all_partitions in
+
+             select_single ~stage:"Root filesystem" 60
+               "Select root filesystem"
+               items in
+
+       let config_target =
+         match !config_target with
+         | Some t -> t
+         | None ->
+             open_centered_window ~stage:"Target system" 40 20
+               "Configure target system";
+
+             let hvlabel = Newt.label 1 1 "Hypervisor:" in
+             let hvlistbox = Newt.listbox 16 1 4 [Newt.SCROLL] in
+             Newt.listbox_append_entry hvlistbox "Xen" (Some Xen);
+             Newt.listbox_append_entry hvlistbox "QEMU" (Some QEMU);
+             Newt.listbox_append_entry hvlistbox "KVM" (Some KVM);
+             Newt.listbox_append_entry hvlistbox "Other" None;
+
+             let archlabel = Newt.label 1 5 "Architecture:" in
+             let archlistbox = Newt.listbox 16 5 4 [Newt.SCROLL] in
+             Newt.listbox_append_entry archlistbox "i386" I386;
+             Newt.listbox_append_entry archlistbox
+                   "x86-64 (64-bit x86)" X86_64;
+             Newt.listbox_append_entry archlistbox "IA64 (Itanium)" IA64;
+             Newt.listbox_append_entry archlistbox "PowerPC 32-bit" PPC;
+             Newt.listbox_append_entry archlistbox "PowerPC 64-bit" PPC64;
+             Newt.listbox_append_entry archlistbox "SPARC 32-bit" SPARC;
+             Newt.listbox_append_entry archlistbox "SPARC 64-bit" SPARC64;
+             Newt.listbox_append_entry archlistbox "Unknown/other" UnknownArch;
+
+             (* Get the architecture of the selected root filesystem.
+              * If not known, default to UnknownArch.
+              *)
+             Newt.listbox_set_current_by_key archlistbox UnknownArch;
+             (try
+                match List.assoc config_root_filesystem all_partitions with
+                | LinuxRoot (arch, _) ->
+                    Newt.listbox_set_current_by_key archlistbox arch
+                | _ -> ()
+               with
+                 Not_found -> ());

 
 

-  let ask_hypervisor state =
-    match
-    radiolist "Hypervisor"
-      "Choose hypervisor / virtualization system"
-      11 50 4 [
-       "xen", "Xen", state.hypervisor = Some Xen;
-       "qemu", "QEMU", state.hypervisor = Some QEMU;
-       "kvm", "KVM", state.hypervisor = Some KVM;
-       "other", "Other", state.hypervisor = None
-      ]
-    with
-    | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
-    | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
-    | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
-    | Yes _ -> Next { state with hypervisor = None }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+             let memlabel = Newt.label 1 9 "Memory (MB):" in
+             let mementry = Newt.entry 16 9
+               (Some (string_of_int system_memory)) 8 [] in
+             let cpulabel = Newt.label 1 10 "CPUs:" in
+             let cpuentry = Newt.entry 16 10
+               (Some (string_of_int system_nr_cpus)) 4 [] in
+             let maclabel = Newt.label 1 11 "MAC addr:" in
+             let macentry = Newt.entry 16 11 None 20 [] in
+             let maclabel2 = Newt.label 1 12 "(leave MAC blank for random)" in

 
 

-  let ask_architecture state =
-    match
-    radiolist "Architecture" "Machine architecture" 16 50 8 [
-      "i386", "i386 and up (32 bit)", state.architecture = Some I386;
-      "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
-      "ia64", "Itanium IA64", state.architecture = Some IA64;
-      "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
-      "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
-      "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
-      "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
-      "auto", "Auto-detect",
-        state.architecture = None || state.architecture = Some UnknownArch;
-    ]
-    with
-    | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
-    | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
-    | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
-    | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
-    | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
-    | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
-    | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
-    | Yes _ -> Next { state with architecture = Some UnknownArch }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+             let libvirtd =
+               Newt.checkbox 12 14 "Use remote libvirtd" '*' None in

 
 

-  let ask_memory state =
-    match
-    inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
-      10 50
-      (Option.map_default string_of_int "" state.memory)
-    with
-    | Yes (""::_ | []) -> Next { state with memory = Some 0 }
-    | Yes (mem::_) ->
-       let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
-       if mem < 0 || (mem > 0 && mem < 64) then Ask_again
-       else Next { state with memory = Some mem }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+             let ok = Newt.button 28 16 "  OK  " in

 
 

-  let ask_vcpus state =
-    match
-    inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
-      10 50
-      (Option.map_default string_of_int "" state.vcpus)
-    with
-    | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
-    | Yes (vcpus::_) ->
-       let vcpus =
-         try int_of_string vcpus with Failure "int_of_string" -> -1 in
-       if vcpus < 0 then Ask_again
-       else Next { state with vcpus = Some vcpus }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+             let form = Newt.form None None [] in
+             Newt.form_add_components form
+               [hvlabel; Newt.component_of_listbox hvlistbox;
+                archlabel; Newt.component_of_listbox archlistbox;
+                memlabel; mementry;
+                cpulabel; cpuentry;
+                maclabel; macentry; maclabel2;
+                libvirtd;
+                ok];
+
+             let c =
+               let rec loop () =
+                 ignore (Newt.run_form form);
+                 try
+                   let hv = Newt.listbox_get_current hvlistbox in
+                   let arch = Newt.listbox_get_current archlistbox in
+                   let mem = int_of_string (Newt.entry_get_value mementry) in
+                   let cpus = int_of_string (Newt.entry_get_value cpuentry) in
+                   let mac = Newt.entry_get_value macentry in
+                   let libvirtd = Newt.checkbox_get_value libvirtd = '*' in
+                   if hv <> None && arch <> None && mem >= 0 && cpus >= 0
+                   then
+                     { tgt_hypervisor = Option.get hv;
+                       tgt_architecture = Option.get arch;
+                       tgt_memory = mem; tgt_vcpus = cpus;
+                       tgt_mac_address =
+                         if mac <> "" then mac else random_mac_address ();
+                       tgt_libvirtd = libvirtd }
+                   else
+                     loop ()
+                 with
+                   Not_found | Failure "int_of_string" -> loop ()
+               in
+               loop () in

 
 

-  let ask_mac_address state =
-    match
-    inputbox "MAC address"
-      "Network MAC address. Leave blank to use a random address." 10 50
-      (Option.default "" state.mac_address)
-    with
-    | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
-    | Yes (mac :: _) -> Next { state with mac_address = Some mac }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+             Newt.pop_window ();

 
 

-  let ask_compression state =
-    match
-    radiolist "Network compression" "Enable network compression" 10 50 2 [
-      "yes", "Yes, compress network traffic", state.compression <> Some false;
-      "no", "No, don't compress", state.compression = Some false
-    ]
-    with
-    | Yes ("no"::_) -> Next { state with compression = Some false }
-    | Yes _ -> Next { state with compression = Some true }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+             c in

 
 

-  let ask_verify state =
-    match
-    yesno "Verify and proceed"
-      (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
-
-Host:port:    %s : %s
-Directory:    %s
-Network:      %s
-Send devices: %s
-Root (/) dev: %s
-Hypervisor:   %s
-Architecture: %s
-Memory:       %s
-VCPUs:        %s
-MAC address:  %s
-Compression:  %b"
-         (Option.default "" state.remote_host)
-         (Option.default "" state.remote_port)
-         (Option.default "" state.remote_directory)
-         (match state.network with
-         | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
-         | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
-         | None -> "")
-         (String.concat "," (Option.default [] state.devices_to_send))
-         (Option.map_default dev_of_partition "" state.root_filesystem)
-         (match state.hypervisor with
-         | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
-         | None -> "Other / not set")
-         (match state.architecture with
-         | Some UnknownArch -> "Auto-detect"
-         | Some arch -> string_of_architecture arch | None -> "")
-         (match state.memory with
-         | Some 0 -> "Same as physical"
-         | Some mem -> string_of_int mem ^ " MB" | None -> "")
-         (match state.vcpus with
-         | Some 0 -> "Same as physical"
-         | Some vcpus -> string_of_int vcpus | None -> "")
-         (match state.mac_address with
-         | Some "" -> "Random" | Some mac -> mac | None -> "")
-         (Option.default true state.compression)
-      )
-      21 50
-    with
-    | Yes _ -> Next state
-    | Back -> Prev
-    | No | Help | Error -> Ask_again
-  in
+       config_devices_to_send, config_root_filesystem, config_target
+    ) in

 
 

-  (* This is the list of dialogs, in order.  The user can go forwards or
-   * backwards through them.
-   *
-   * The second parameter in each tuple is true if we need to skip
-   * this dialog statically (info already supplied in 'defaults' above).
-   *
-   * The third parameter in each tuple is a function that tests whether
-   * this dialog should be skipped, given other parts of the current state.
+  (* Try to get the capabilities from the remote machine.  If we fail
+   * it doesn't matter too much.

    *)
    *)

-  let dlgs =
-    let dont_skip _ = false in
-    [|
-    ask_greeting,      not defaults.greeting,             dont_skip;
-    ask_hostname,      defaults.remote_host <> None,      dont_skip;
-    ask_port,          defaults.remote_port <> None,      dont_skip;
-    ask_directory,     defaults.remote_directory <> None, dont_skip;
-    ask_username,      defaults.remote_username <> None,  dont_skip;
-    ask_network,       defaults.network <> None,          dont_skip;
-    ask_static_network_config,
-      defaults.static_network_config <> None,
-      (function { network = Some Static } -> false | _ -> true);
-    ask_devices,       defaults.devices_to_send <> None,  dont_skip;
-    ask_root,          defaults.root_filesystem <> None,  dont_skip;
-    ask_hypervisor,    defaults.hypervisor <> None,       dont_skip;
-    ask_architecture,  defaults.architecture <> None,     dont_skip;
-    ask_memory,        defaults.memory <> None,           dont_skip;
-    ask_vcpus,         defaults.vcpus <> None,            dont_skip;
-    ask_mac_address,   defaults.mac_address <> None,      dont_skip;
-    ask_compression,   defaults.compression <> None,      dont_skip;
-    ask_verify,        not defaults.greeting,             dont_skip;
-  |] in
-
-  (* Loop through the dialogs until we reach the end. *)
-  let rec loop ?(back=false) posn state =
-    eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
-    if posn >= Array.length dlgs then state (* Finished all dialogs. *)
-    else if posn < 0 then loop 0 state
-    else (
-      let dlg, skip_static, skip_dynamic = dlgs.(posn) in
-      if skip_static || skip_dynamic state then
-       (* Skip this dialog. *)
-       loop ~back (if back then posn-1 else posn+1) state
-      else (
-       (* Run dialog. *)
-       match dlg state with
-       | Next new_state -> loop (posn+1) new_state (* Forwards. *)
-       | Ask_again -> loop posn state  (* Repeat the question. *)
-       | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
-      )
-    )
-  in
-  let state = loop 0 defaults in
-
-  eprintf "finished dialog loop\n%!";
-
-  (* In test mode, exit here before we do bad things to the developer's
+  let capabilities =
+    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 "fetch capabilities from %S\n%!" name;
+
+      let conn = Libvirt.Connect.connect_readonly ~name () in
+      let caps = Libvirt.Connect.get_capabilities conn in
+      Libvirt.Connect.close conn;
+
+      eprintf "capabilities:\n%s\n%!" caps;
+
+      Some caps
+    with
+    | Not_found -> None
+    | Libvirt.Virterror err ->
+       eprintf "libvirt error: %s\n%!" (Libvirt.Virterror.to_string err);
+       None
+    | Invalid_argument str ->
+       eprintf "libvirt error: %s\n%!" str;
+       None in
+
+  (* In test mode, exit here before we do Bad Things to the developer's

    * hard disk.
    *)
   if test_dialog_stages then exit 1;
    * hard disk.
    *)
   if test_dialog_stages then exit 1;


@@ -1415,28 +1436,26 @@ Compression:  %b"
   sh "rm -f /etc/lvm.new/cache/.cache";
 
   (* Snapshot the block devices to send. *)
   sh "rm -f /etc/lvm.new/cache/.cache";
 
   (* Snapshot the block devices to send. *)

-  let devices_to_send = Option.get state.devices_to_send in
-  let devices_to_send =
+  let config_devices_to_send =

     List.map (
       fun origin_dev ->
        let snapshot_dev = snapshot_name origin_dev in
        snapshot origin_dev snapshot_dev;
        (origin_dev, snapshot_dev)
     List.map (
       fun origin_dev ->
        let snapshot_dev = snapshot_name origin_dev in
        snapshot origin_dev snapshot_dev;
        (origin_dev, snapshot_dev)

-    ) devices_to_send in
+    ) config_devices_to_send in

 
   (* Run kpartx on the snapshots. *)
   List.iter (
     fun (origin, snapshot) ->
       shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
 
   (* Run kpartx on the snapshots. *)
   List.iter (
     fun (origin, snapshot) ->
       shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))

-  ) devices_to_send;
+  ) config_devices_to_send;

 
   (* Rescan for LVs. *)
   sh "vgscan";
   sh "vgchange -a y";
 
   (* Mount the root filesystem under /mnt/root. *)
 
   (* Rescan for LVs. *)
   sh "vgscan";
   sh "vgchange -a y";
 
   (* Mount the root filesystem under /mnt/root. *)

-  let root_filesystem = Option.get state.root_filesystem in
-  (match root_filesystem with
+  (match config_root_filesystem with

    | Part (dev, partnum) ->
        let dev = dev ^ partnum in
        let snapshot_dev = snapshot_name dev in
    | Part (dev, partnum) ->
        let dev = dev ^ partnum in
        let snapshot_dev = snapshot_name dev in


@@ -1450,41 +1469,35 @@ Compression:  %b"
   );
 
   (* Work out what devices will be called at the remote end. *)
   );
 
   (* Work out what devices will be called at the remote end. *)

-  let devices_to_send = List.map (
+  let config_devices_to_send = List.map (

     fun (origin_dev, snapshot_dev) ->
       let remote_dev = remote_of_origin_dev origin_dev in
       (origin_dev, snapshot_dev, remote_dev)
     fun (origin_dev, snapshot_dev) ->
       let remote_dev = remote_of_origin_dev origin_dev in
       (origin_dev, snapshot_dev, remote_dev)

-  ) devices_to_send in
+  ) config_devices_to_send in

 
   (* Modify files on the root filesystem. *)
 
   (* Modify files on the root filesystem. *)

-  rewrite_fstab state devices_to_send;
+  rewrite_fstab config_devices_to_send;

   (* XXX Other files to rewrite? *)
 
   (* Unmount the root filesystem and sync disks. *)
   sh "umount /mnt/root";
   sh "sync";                           (* Ugh, should be in stdlib. *)
 
   (* XXX Other files to rewrite? *)
 
   (* Unmount the root filesystem and sync disks. *)
   sh "umount /mnt/root";
   sh "sync";                           (* Ugh, should be in stdlib. *)
 

-  (* Get architecture of root filesystem, detected previously. *)
-  let system_architecture =
-    try
-      (match List.assoc root_filesystem all_partitions with
-       | LinuxRoot (arch, _) -> arch
-       | _ -> raise Not_found
-      )
-    with
-      Not_found ->
-       (* None was detected before, so assume same as live CD. *)
+  (* 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 = shget "uname -m" in

-       match arch with
-       | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
-       | Some ("x86_64"::_) -> X86_64
-       | Some ("ia64"::_) -> IA64
-       | _ -> I386 (* probably wrong XXX *) in
-
-  let remote_host = Option.get state.remote_host in
-  let remote_port = Option.get state.remote_port in
-  let remote_directory = Option.get state.remote_directory in
-  let remote_username = Option.get state.remote_username in
+       let arch =
+         match arch with
+         | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
+         | Some ("x86_64"::_) -> X86_64
+         | Some ("ia64"::_) -> IA64
+         | _ -> I386 (* probably wrong XXX *) in
+       { config_target with tgt_architecture = arch }
+    | _ -> config_target in

 
   (* XXX This is using the hostname derived from network configuration
    * above.  We might want to ask the user to choose.
 
   (* XXX This is using the hostname derived from network configuration
    * above.  We might want to ask the user to choose.


@@ -1496,11 +1509,11 @@ Compression:  %b"
     "p2v-" ^ hostname ^ "-" ^ date in
 
   (* Work out what the image filenames will be at the remote end. *)
     "p2v-" ^ hostname ^ "-" ^ date in
 
   (* Work out what the image filenames will be at the remote end. *)

-  let devices_to_send = List.map (
+  let config_devices_to_send = List.map (

     fun (origin_dev, snapshot_dev, remote_dev) ->
       let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
       (origin_dev, snapshot_dev, remote_dev, remote_name)
     fun (origin_dev, snapshot_dev, remote_dev) ->
       let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
       (origin_dev, snapshot_dev, remote_dev, remote_name)

-  ) devices_to_send in
+  ) config_devices_to_send in

 
   (* Write a configuration file.  Not sure if this is any better than
    * just 'sprintf-ing' bits of XML text together, but at least we will
 
   (* Write a configuration file.  Not sure if this is any better than
    * just 'sprintf-ing' bits of XML text together, but at least we will


@@ -1515,23 +1528,6 @@ Compression:  %b"
    *)
   let conf_filename = basename ^ ".conf" in
 
    *)
   let conf_filename = basename ^ ".conf" in
 

-  let architecture =
-    match state.architecture with
-    | Some UnknownArch | None -> system_architecture
-    | Some arch -> arch in
-  let memory =
-    match state.memory with
-    | Some 0 | None -> system_memory
-    | Some memory -> memory in
-  let vcpus =
-    match state.vcpus with
-    | Some 0 | None -> system_nr_cpus
-    | Some n -> n in
-  let mac_address =
-    match state.mac_address with
-    | Some "" | None -> random_mac_address ()
-    | Some mac -> mac in
-

   let xml =
     (* Shortcut to make "<name>value</name>". *)
     let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
   let xml =
     (* Shortcut to make "<name>value</name>". *)
     let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in


@@ -1541,15 +1537,17 @@ Compression:  %b"
     (* Standard stuff for every domain. *)
     let name = leaf "name" hostname in
     let uuid = leaf "uuid" (random_uuid ()) in
     (* Standard stuff for every domain. *)
     let name = leaf "name" hostname in
     let uuid = leaf "uuid" (random_uuid ()) in

-    let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
-    let memory = leaf "memory" (string_of_int (memory * 1024)) in
-    let vcpu = leaf "vcpu" (string_of_int vcpus) in
+    let maxmem, memory =
+      let m =
+       leaf "maxmem" (string_of_int (config_target.tgt_memory * 1024)) in
+      m, m in
+    let vcpu = leaf "vcpu" (string_of_int config_target.tgt_vcpus) in

 
     (* Top-level stuff which differs for each HV type (isn't this supposed
      * to be portable ...)
      *)
     let extras =
 
     (* Top-level stuff which differs for each HV type (isn't this supposed
      * to be portable ...)
      *)
     let extras =

-      match state.hypervisor with
+      match config_target.tgt_hypervisor with

       | Some Xen ->
          [Xml.Element ("os", [],
                        [leaf "type" "hvm";
       | Some Xen ->
          [Xml.Element ("os", [],
                        [leaf "type" "hvm";


@@ -1567,7 +1565,8 @@ Compression:  %b"
          [Xml.Element ("os", [],
                        [Xml.Element ("type",
                                      ["arch",
          [Xml.Element ("os", [],
                        [Xml.Element ("type",
                                      ["arch",

-                                      string_of_architecture architecture;
+                                      string_of_architecture
+                                        config_target.tgt_architecture;

                                       "machine","pc"],
                                      [Xml.PCData "hvm"]);
                         tleaf "boot" ["dev", "hd"]])]
                                       "machine","pc"],
                                      [Xml.PCData "hvm"]);
                         tleaf "boot" ["dev", "hd"]])]


@@ -1577,7 +1576,7 @@ Compression:  %b"
     (* <devices> section. *)
     let devices =
       let emulator =
     (* <devices> section. *)
     let devices =
       let emulator =

-       match state.hypervisor with
+       match config_target.tgt_hypervisor with

        | Some Xen ->
            [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
        | Some QEMU ->
        | Some Xen ->
            [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
        | Some QEMU ->


@@ -1588,7 +1587,8 @@ Compression:  %b"
            [] in
       let interface =
        Xml.Element ("interface", ["type", "user"],
            [] in
       let interface =
        Xml.Element ("interface", ["type", "user"],

-                    [tleaf "mac" ["address", mac_address]]) in
+                    [tleaf "mac" ["address",
+                                  config_target.tgt_mac_address]]) in

       (* XXX should have an option for Xen bridging:
        Xml.Element (
        "interface", ["type","bridge"],
       (* XXX should have an option for Xen bridging:
        Xml.Element (
        "interface", ["type","bridge"],


@@ -1602,10 +1602,11 @@ Compression:  %b"
          Xml.Element (
            "disk", ["type", "file";
                     "device", "disk"],
          Xml.Element (
            "disk", ["type", "file";
                     "device", "disk"],

-           [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
+           [tleaf "source" ["file",
+                            config_ssh.ssh_directory ^ "/" ^ remote_name];

             tleaf "target" ["dev", remote_dev]]
          )
             tleaf "target" ["dev", remote_dev]]
          )

-      ) devices_to_send in
+      ) config_devices_to_send in

 
       Xml.Element (
        "devices", [],
 
       Xml.Element (
        "devices", [],


@@ -1615,7 +1616,7 @@ Compression:  %b"
     (* Put it all together in <domain type='foo'>. *)
     Xml.Element (
       "domain",
     (* Put it all together in <domain type='foo'>. *)
     Xml.Element (
       "domain",

-      (match state.hypervisor with
+      (match config_target.tgt_hypervisor with

        | Some Xen -> ["type", "xen"]
        | Some QEMU -> ["type", "qemu"]
        | Some KVM -> ["type", "kvm"]
        | Some Xen -> ["type", "xen"]
        | Some QEMU -> ["type", "qemu"]
        | Some KVM -> ["type", "kvm"]


@@ -1630,7 +1631,7 @@ Compression:  %b"
     let xml = Xml.to_string_fmt xml in
 
     let conn_arg =
     let xml = Xml.to_string_fmt xml in
 
     let conn_arg =

-      match state.hypervisor with
+      match config_target.tgt_hypervisor with

       | Some Xen | None -> ""
       | Some QEMU | Some KVM -> " -c qemu:///system" in
     let xml = sprintf "\
       | Some Xen | None -> ""
       | Some QEMU | Some KVM -> " -c qemu:///system" in
     let xml = sprintf "\


@@ -1645,10 +1646,10 @@ Compression:  %b"
     let xml_len = String.length xml in
     eprintf "length of configuration file is %d bytes\n%!" xml_len;
 
     let xml_len = String.length xml in
     eprintf "length of configuration file is %d bytes\n%!" xml_len;
 

-    let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
+    let (sock,_) as conn = ssh_start_upload config_ssh conf_filename in

     (* In OCaml this actually loops calling write(2) *)
     ignore (write sock xml 0 xml_len);
     (* In OCaml this actually loops calling write(2) *)
     ignore (write sock xml 0 xml_len);

-    do_disconnect conn in
+    ssh_finish_upload conn in

 
   (* Send the device snapshots to the remote host. *)
   (* XXX This code should be made more robust against both network
 
   (* Send the device snapshots to the remote host. *)
   (* XXX This code should be made more robust against both network


@@ -1670,7 +1671,7 @@ Compression:  %b"
       let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
 
       (* Now connect. *)
       let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
 
       (* Now connect. *)

-      let (sock,_) as conn = do_connect remote_name size in
+      let (sock,_) as conn = ssh_start_upload config_ssh remote_name in

 
       (* Copy the data. *)
       let spinners = "|/-\\" (* "Oo" *) in
 
       (* Copy the data. *)
       let spinners = "|/-\\" (* "Oo" *) in


@@ -1717,22 +1718,21 @@ Compression:  %b"
       printf "\n\n%!"; (* because of the messages printed above *)
 
       (* Disconnect. *)
       printf "\n\n%!"; (* because of the messages printed above *)
 
       (* Disconnect. *)

-      do_disconnect conn
-  ) devices_to_send;
+      ssh_finish_upload conn
+  ) config_devices_to_send;

 
   (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
 
   (* Clean up and reboot. *)
   ignore (
 
   (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
 
   (* Clean up and reboot. *)
   ignore (

-    msgbox (sprintf "%s completed" program_name)
+    message_box (sprintf "%s completed" program_name)

       (sprintf "\nThe physical to virtual migration is complete.\n\nPlease verify the disk image(s) and configuration file on the remote host, and then start up the virtual machine by doing:\n\ncd %s\nvirsh define %s\n\nWhen you press [OK] this machine will reboot."
       (sprintf "\nThe physical to virtual migration is complete.\n\nPlease verify the disk image(s) and configuration file on the remote host, and then start up the virtual machine by doing:\n\ncd %s\nvirsh define %s\n\nWhen you press [OK] this machine will reboot."

-        remote_directory conf_filename)
-      17 50
+        config_ssh.ssh_directory conf_filename)

   );
 
   shfailok "eject";
   shfailok "reboot";
   );
 
   shfailok "eject";
   shfailok "reboot";

-*)
+

   exit 0
 
 (*----------------------------------------------------------------------*)
   exit 0
 
 (*----------------------------------------------------------------------*)