X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=virt-p2v.ml;h=7801a21eae07bc0e739f39674b99436a7824d1cc;hb=75afd7e7c6b3547e6d8d63b170589d807ae54316;hp=6c9a35ab388f757aff76cf1f55ff21484fc84a54;hpb=29ee4297592dcde61dd3dacd304ee4f4b38c5182;p=virt-p2v.git

diff --git a/virt-p2v.ml b/virt-p2v.ml
index 6c9a35a..7801a21 100755
--- a/virt-p2v.ml
+++ b/virt-p2v.ml
@@ -1,5 +1,12 @@
 #!/usr/bin/ocamlrun /usr/bin/ocaml
 #load "unix.cma";;
+#directory "+extlib";;
+#load "extLib.cma";;
+#directory "+pcre";;
+#load "pcre.cma";;
+#directory "+xml-light";;
+#load "xml-light.cma";;
+
 (* virt-p2v.ml is a script which performs a physical to
  * virtual conversion of local disks.
  *
@@ -23,19 +30,26 @@
 
 open Unix
 open Printf
+open ExtList
+open ExtString
 
 type state = { greeting : bool;
 	       remote_host : string option; remote_port : string option;
-	       remote_transport : transport option;
+	       transport : transport option;
 	       remote_directory : string option;
+	       network : network option;
 	       devices_to_send : string list option;
-	       root_filesystem : string option; network : network option }
-and transport = SSH | TCP
+	       root_filesystem : partition option;
+	       hypervisor : hypervisor option;
+	       architecture : string option;
+	       memory : int option; vcpus : int option;
+	       mac_address : string option;
+	     }
+and transport = Server | SSH
 and network = Auto | Shell
-
-type dialog_status = Yes | No | Help | Extra | Error
-
-let default d = function None -> d | Some p -> p
+and partition = Part of string * string (* eg. "hda", "1" *)
+              | LV of string * string	(* eg. "VolGroup00", "LogVol00" *)
+and hypervisor = Xen | QEMU | KVM
 
 (*----------------------------------------------------------------------*)
 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
@@ -54,10 +68,10 @@ let defaults = {
    *)
   greeting = true;
 
-  (* Transport: Set to 'Some SSH' or 'Some TCP' to assume SSH or TCP
-   * respectively.
+  (* Transport: Set to 'Some Server' or 'Some SSH' to assume Server or SSH
+   * transports respectively.
    *)
-  remote_transport = None;
+  transport = None;
 
   (* Remote host and port.  Set to 'Some "host"' and 'Some "port"',
    * else ask the user.
@@ -75,8 +89,9 @@ let defaults = {
    *)
   devices_to_send = None;
 
-  (* The root filesystem containing /etc/fstab.  Set to 'Some "sda3"'
-   * or 'Some "VolGroup00/LogVol00"' for example, else ask user.
+  (* The root filesystem containing /etc/fstab.  Set to
+   * 'Some (Part ("sda", "3"))' or 'Some (LV ("VolGroup00", "LogVol00"))'
+   * for example, else ask user.
    *)
   root_filesystem = None;
 
@@ -85,10 +100,401 @@ let defaults = {
    *)
   network = None;
 
+  (* Hypervisor: Set to 'Some Xen', 'Some QEMU' or 'Some KVM'. *)
+  hypervisor = None;
+
+  (* Architecture: Set to 'Some "x86_64"' (or another architecture).
+   * If set to 'Some ""' then we try to autodetect the right architecture.
+   *)
+  architecture = None;
+
+  (* Memory: Set to 'Some nn' with nn in megabytes.  If set to 'Some 0'
+   * then we use same amount of RAM as installed in the physical machine.
+   *)
+  memory = None;
+
+  (* Virtual CPUs: Set to 'Some nn' where nn is the number of virtual CPUs.
+   * If set to 'Some 0' then we use the same as physical CPUs in the
+   * physical machine.
+   *)
+  vcpus = None;
+
+  (* MAC address: Set to 'Some "aa:bb:cc:dd:ee:ff"' where the string is
+   * the MAC address of the emulated network card.  Set to 'Some ""' to
+   * choose a random MAC address.
+   *)
+  mac_address = None;
 }
 (* END OF CUSTOM virt-p2v SCRIPT SECTION.                               *)
 (*----------------------------------------------------------------------*)
 
+(* General helper functions. *)
+
+let sort_uniq ?(cmp = compare) xs =	(* sort and uniq a list *)
+  let xs = List.sort ~cmp xs in
+  let rec loop = function
+    | [] -> [] | [x] -> [x]
+    | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
+    | x :: xs -> x :: loop xs
+  in
+  loop xs
+
+let input_all_lines chan =
+  let lines = ref [] in
+  try
+    while true do lines := input_line chan :: !lines done; []
+  with
+    End_of_file -> List.rev !lines
+
+let dev_of_partition = function
+  | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
+  | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
+
+type dialog_status = Yes of string list | No | Help | Back | Error
+
+type ask_result = Next of state | Prev | Ask_again
+
+(* Dialog functions.
+ *
+ * Each function takes some common parameters (eg. ~title) and some
+ * dialog-specific parameters.
+ *
+ * Returns the exit status (Yes lines | No | Help | Back | Error).
+ *)
+let msgbox, yesno, inputbox, radiolist, checklist =
+  (* Internal function to actually run the "dialog" shell command. *)
+  let run_dialog cparams params =
+    let params = cparams @ params in
+    eprintf "dialog %s\n%!"
+      (String.concat " " (List.map (sprintf "%S") params));
+
+    (* 'dialog' writes its output/result to stderr, so we need to take
+     * special steps to capture that - in other words, manual pipe/fork.
+     *)
+    let rfd, wfd = pipe () in
+    match fork () with
+    | 0 ->				(* child, runs dialog *)
+	close rfd;
+	dup2 wfd stderr;		(* capture stderr to pipe *)
+	execvp "dialog" (Array.of_list ("dialog" :: params))
+    | pid ->				(* parent *)
+	close wfd;
+	let chan = in_channel_of_descr rfd in
+	let result = input_all_lines chan in
+	close rfd;
+	eprintf "dialog result: %S\n%!" (String.concat "\n" result);
+	match snd (wait ()) with
+	| WEXITED 0 -> Yes result       (* something selected / entered *)
+	| WEXITED 1 -> No		(* cancel / no button *)
+	| WEXITED 2 -> Help		(* help pressed *)
+	| WEXITED 3 -> Back		(* back button *)
+	| WEXITED _ -> Error		(* error or Esc *)
+	| WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
+	| WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
+  in
+
+  (* Handle the common parameters.  Note Continuation Passing Style. *)
+  let with_common cont ?(cancel=false) ?(backbutton=true) title =
+    let params = ["--title"; title] in
+    let params = if not cancel then "--nocancel" :: params else params in
+    let params =
+      if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
+      else params in
+    cont params
+  in
+
+  (* Message box and yes/no box. *)
+  let rec msgbox =
+    with_common (
+      fun cparams text height width ->
+	run_dialog cparams
+	  [ "--msgbox"; text; string_of_int height; string_of_int width ]
+    )
+  and yesno =
+    with_common (
+      fun cparams text height width ->
+	run_dialog cparams
+	  [ "--yesno"; text; string_of_int height; string_of_int width ]
+    )
+
+  (* Simple input box. *)
+  and inputbox =
+    with_common (
+      fun cparams text height width default ->
+	run_dialog cparams
+	  [ "--inputbox"; text; string_of_int height; string_of_int width;
+	    default ]
+    )
+
+  (* Radio list and check list. *)
+  and radiolist =
+    with_common (
+      fun cparams text height width listheight items ->
+	let items = List.map (
+	  function
+	  | tag, item, true -> [ tag; item; "on" ]
+	  | tag, item, false -> [ tag; item; "off" ]
+	) items in
+	let items = List.concat items in
+	let items = "--single-quoted" ::
+	  "--radiolist" :: text ::
+	  string_of_int height :: string_of_int width ::
+	  string_of_int listheight :: items in
+	run_dialog cparams items
+    )
+  and checklist =
+    with_common (
+      fun cparams text height width listheight items ->
+	let items = List.map (
+	  function
+	  | tag, item, true -> [ tag; item; "on" ]
+	  | tag, item, false -> [ tag; item; "off" ]
+	) items in
+	let items = List.concat items in
+	let items = "--separate-output" ::
+	  "--checklist" :: text ::
+	  string_of_int height :: string_of_int width ::
+	  string_of_int listheight :: items in
+	run_dialog cparams items
+    )
+  in
+  msgbox, yesno, inputbox, radiolist, checklist
+
+(* Print failure dialog and exit. *)
+let fail_dialog text =
+  let text = "\n" ^ text ^ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in
+  ignore (msgbox "Error" text 17 50);
+  exit 1
+
+(* Shell-safe quoting function.  In fact there's one in stdlib so use it. *)
+let quote = Filename.quote
+
+(* Run a shell command and check it returns 0. *)
+let sh cmd =
+  eprintf "sh: %s\n%!" cmd;
+  if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
+
+let shfailok cmd =
+  eprintf "shfailok: %s\n%!" cmd;
+  ignore (Sys.command cmd)
+
+let shwithstatus cmd =
+  eprintf "shwithstatus: %s\n%!" cmd;
+  Sys.command cmd
+
+(* Same as `cmd` in shell.  Any error message will be in the logfile. *)
+let shget cmd =
+  eprintf "shget: %s\n%!" cmd;
+  let chan = open_process_in cmd in
+  let lines = input_all_lines chan in
+  match close_process_in chan with
+  | WEXITED 0 -> Some lines		(* command succeeded *)
+  | WEXITED _ -> None			(* command failed *)
+  | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
+  | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
+
+(* Start an interactive shell. *)
+let shell () =
+  shfailok "PS1='\\u@\\h:\\w\\$ ' bash"
+
+(* Some true if is dir/file, Some false if not, None if not found. *)
+let is_dir path =
+  try Some ((stat path).st_kind = S_DIR)
+  with Unix_error (ENOENT, "stat", _) -> None
+let is_file path =
+  try Some ((stat path).st_kind = S_REG)
+  with Unix_error (ENOENT, "stat", _) -> None
+
+(* Useful regular expression. *)
+let whitespace = Pcre.regexp "[ \t]+"
+
+(* Generate a predictable safe name containing only letters, numbers
+ * and underscores.  If passed a string with no letters or numbers,
+ * generates "_1", "_2", etc.
+ *)
+let safe_name =
+  let next_anon =
+    let i = ref 0 in
+    fun () -> incr i; "_" ^ string_of_int !i
+  in
+  fun name ->
+    let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
+    let name = String.copy name in
+    let have_safe = ref false in
+    for i = 0 to String.length name - 1 do
+      if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
+    done;
+    if !have_safe then name else next_anon ()
+
+type block_device = string * int64	(* "hda" & size in bytes *)
+
+(* Parse the output of 'lvs' to get list of LV names, sizes,
+ * corresponding PVs, etc.  Returns a list of (lvname, PVs, lvsize).
+ *)
+let get_lvs =
+  let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
+
+  function () ->
+    match
+    shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
+    with
+    | None -> []
+    | Some lines ->
+	let lines = List.map (Pcre.split ~rex:whitespace) lines in
+	List.map (
+	  function
+	  | [vg; lv; pvs; lvsize]
+	  | [_; vg; lv; pvs; lvsize] ->
+	      let pvs = String.nsplit pvs "," in
+	      let pvs = List.filter_map (
+		fun pv ->
+		  try
+		    let subs = Pcre.exec ~rex:devname pv in
+		    Some (Pcre.get_substring subs 1)
+		  with
+		    Not_found ->
+		      eprintf "lvs: unexpected device name: %s\n%!" pv;
+		      None
+	      ) pvs in
+	      LV (vg, lv), pvs, lvsize
+	  | line ->
+	      failwith ("lvs: unexpected output: " ^ String.concat "," line)
+	) lines
+
+(* Get the partitions on a block device.
+ * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
+ *)
+let get_partitions dev =
+  let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
+  let devdir = "/sys/block/" ^ dev in
+  let parts = Sys.readdir devdir in
+  let parts = Array.to_list parts in
+  let parts = List.filter (
+    fun name -> Some true = is_dir (devdir ^ "/" ^ name)
+  ) parts in
+  let parts = List.filter_map (
+    fun part ->
+      try
+	let subs = Pcre.exec ~rex part in
+	Some (Part (dev, Pcre.get_substring subs 1))
+      with
+	Not_found -> None
+  ) parts in
+  parts
+
+(* Generate snapshot device name from device name. *)
+let snapshot_name dev =
+  "snap" ^ (safe_name dev)
+
+(* Perform a device-mapper snapshot with ramdisk overlay. *)
+let snapshot =
+  let next_free_ram_disk =
+    let i = ref 0 in
+    fun () -> incr i; "/dev/ram" ^ string_of_int !i
+  in
+  fun origin_dev snapshot_dev ->
+    let ramdisk = next_free_ram_disk () in
+    let sectors =
+      let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
+      let lines = shget cmd in
+      match lines with
+      | Some (sectors::_) -> Int64.of_string sectors
+      | Some [] | None ->
+	  fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
+
+    (* Create the snapshot origin device.  Called, eg. snap_sda1_org *)
+    sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
+	  snapshot_dev sectors origin_dev);
+    (* Create the snapshot. *)
+    sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
+	  snapshot_dev sectors snapshot_dev ramdisk)
+
+(* Try to perform automatic network configuration, assuming a Fedora or RHEL-
+ * like root filesystem mounted on /mnt/root.
+ *)
+let auto_network state =
+  (* Fedora gives an error if this file doesn't exist. *)
+  sh "touch /etc/resolv.conf";
+
+  chdir "/etc/sysconfig";
+
+  sh "mv network network.saved";
+  sh "mv networking networking.saved";
+  sh "mv network-scripts network-scripts.saved";
+
+  (* Originally I symlinked these, but that causes dhclient to
+   * keep open /mnt/root (as its cwd is in network-scripts subdir).
+   * So now we will copy them recursively instead.
+   *)
+  sh "cp -r /mnt/root/etc/sysconfig/network .";
+  sh "cp -r /mnt/root/etc/sysconfig/networking .";
+  sh "cp -r /mnt/root/etc/sysconfig/network-scripts .";
+
+  let status = shwithstatus "/etc/init.d/network start" in
+
+  sh "rm -rf network networking network-scripts";
+  sh "mv network.saved network";
+  sh "mv networking.saved networking";
+  sh "mv network-scripts.saved network-scripts";
+
+  chdir "/tmp";
+
+  (* Try to ping the remote host to see if this worked. *)
+  shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
+
+  if state.greeting then (
+    printf "\n\nDid automatic network configuration work?\n";
+    printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
+    printf "    (y/n) %!";
+    let line = read_line () in
+    String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
+  )
+  else
+    (* Non-interactive: return the status of /etc/init.d/network start. *)
+    status = 0
+
+(* Map local device names to remote devices names.  At the moment we
+ * just change sd* to hd* (as device names appear under fullvirt).  In
+ * future, lots of complex possibilities.
+ *)
+let remote_of_origin_dev =
+  let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
+  let devsd_subst = Pcre.subst "hd$1" in
+  fun dev ->
+    Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
+
+(* Rewrite /mnt/root/etc/fstab. *)
+let rewrite_fstab state 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 chan = open_in filename in
+    let lines = input_all_lines chan in
+    close_in chan;
+    let lines = List.map (Pcre.split ~rex:whitespace) lines in
+    let lines = List.map (
+      function
+      | dev :: rest when String.starts_with dev "/dev/" ->
+	  let dev = String.sub dev 5 (String.length dev - 5) in
+	  let dev = remote_of_origin_dev dev in
+	  let dev = "/dev/" ^ dev in
+	  dev :: rest
+      | line -> line
+    ) lines in
+
+    let chan = open_out filename in
+    List.iter (
+      function
+      | [dev; mountpoint; fstype; options; freq; passno] ->
+	  fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
+	    dev mountpoint fstype options freq passno
+      | line ->
+	  output_string chan (String.concat " " line)
+    ) lines;
+    close_out chan
+  )
+
 (* Main entry point. *)
 let rec main ttyname =
   (* Running from an init script.  We don't have much of a
@@ -112,7 +518,7 @@ let rec main ttyname =
   (* Log the start up time. *)
   eprintf "\n\n**************************************************\n\n";
   let tm = localtime (time ()) in
-  eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n%!"
+  eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
     (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
 
   (* Connect stdin/stdout to the tty. *)
@@ -123,49 +529,309 @@ let rec main ttyname =
        dup2 fd stdin;
        dup2 fd stdout;
        close fd);
+  printf "virt-p2v.ml starting up ...\n%!";
+
+  (* Search for all non-removable block devices.  Do this early and bail
+   * if we can't find anything.  This is a list of strings, like "hda".
+   *)
+  let all_block_devices : block_device list =
+    let rex = Pcre.regexp "^[hs]d" in
+    let devices = Array.to_list (Sys.readdir "/sys/block") in
+    let devices = List.sort devices in
+    let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
+    eprintf "all_block_devices: block devices: %s\n%!"
+      (String.concat "; " devices);
+    (* Run blockdev --getsize64 on each, and reject any where this fails
+     * (probably removable devices).
+     *)
+    let devices = List.filter_map (
+      fun d ->
+	let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
+	let lines = shget cmd in
+	match lines with
+	| Some (blksize::_) -> Some (d, Int64.of_string blksize)
+	| Some [] | None -> None
+    ) devices in
+    eprintf "all_block_devices: non-removable block devices: %s\n%!"
+      (String.concat "; "
+	 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
+    if devices = [] then
+      fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
+    devices in
+
+  (* Search for partitions and LVs (anything that could contain a
+   * filesystem directly).  We refer to these generically as
+   * "partitions".
+   *)
+  let all_partitions : partition list =
+    (* LVs & PVs. *)
+    let lvs, pvs =
+      let lvs = get_lvs () in
+      let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
+      let pvs = List.concat pvs in
+      let pvs = sort_uniq pvs in
+      eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
+      let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
+      eprintf "all_partitions: LVs: %s\n%!"
+	(String.concat "; " (List.map dev_of_partition lvs));
+      lvs, pvs in
+
+    (* Partitions (eg. "sda1", "sda2"). *)
+    let parts =
+      let parts = List.map fst all_block_devices in
+      let parts = List.map get_partitions parts in
+      let parts = List.concat parts in
+      eprintf "all_partitions: all partitions: %s\n%!"
+	(String.concat "; " (List.map dev_of_partition parts));
+
+      (* Remove any partitions which are PVs. *)
+      let parts = List.filter (
+	function
+	| Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
+	| LV _ -> assert false
+      ) parts in
+      parts in
+    eprintf "all_partitions: partitions after removing PVs: %s\n%!"
+      (String.concat "; " (List.map dev_of_partition parts));
+
+    (* Concatenate LVs & Parts *)
+    lvs @ parts in
 
   (* Dialogs. *)
-  let rec ask_greeting state =
-    ignore (
-      dialog [
-	title "virt-p2v" ();
-	msgbox "\nWelcome to virt-p2v, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password." 17 50
-      ]
-    );
-    Some state
-
-  and ask_transport state =
-    ignore ( (* XXX *)
-    dialog [
-      title "Connection type" ~cancel:false ();
-      radiolist "Connection type" 10 50 2 [
-	"ssh", "SSH (secure shell - recommended)",
-	  state.remote_transport = Some SSH;
-	"tcp", "TCP socket",
-	  state.remote_transport = Some TCP
+  let ask_greeting state =
+    ignore (msgbox "virt-p2v" "\nWelcome to virt-p2v, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password.\n\nExtra information is logged in /tmp/virt-p2v.log but this file disappears when the machine reboots." 18 50);
+    Next state
+  in
+
+  let ask_transport state =
+    match
+    radiolist "Connection type" ~backbutton:false
+      "Connection type."
+      11 50 2 [
+	"ssh", "SSH (secure shell)", state.transport = Some SSH;
+	"server", "P2V server on remote host", state.transport = Some Server
       ]
+    with
+    | Yes ("ssh"::_) -> Next { state with transport = Some SSH }
+    | Yes ("server"::_) -> Next { state with transport = Some Server }
+    | Yes _ | No | Help | Error -> Ask_again
+    | Back -> Prev
+  in
+
+  let ask_hostname state =
+    match
+    inputbox "Remote host" "Remote host" 10 50
+      (Option.default "" state.remote_host)
+    with
+    | Yes [] -> Ask_again
+    | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
+    | No | Help | Error -> Ask_again
+    | Back -> Prev
+  in
+
+  let ask_port state =
+    match
+    inputbox "Remote port" "Remote port" 10 50
+      (Option.default "" state.remote_port)
+    with
+    | Yes [] ->
+	(match state.transport with
+	 | Some SSH -> Next { state with remote_port = Some "22" }
+	 | _ -> Next { state with remote_port = Some "16211" }
+	)
+    | Yes (port::_) -> Next { state with remote_port = Some port }
+    | No | Help | Error -> Ask_again
+    | Back -> Prev
+  in
+
+  let ask_directory state =
+    match
+    inputbox "Remote directory" "Remote directory" 10 50
+      (Option.default "" state.remote_directory)
+    with
+    | Yes [] ->
+	Next { state with remote_directory = Some "/var/lib/xen/images" }
+    | Yes (dir::_) -> Next { state with remote_directory = Some dir }
+    | No | Help | Error -> Ask_again
+    | Back -> Prev
+  in
+
+  let ask_network state =
+    match
+    radiolist "Network configuration" "Network configuration" 10 50 2 [
+      "auto", "Automatic configuration", state.network = Some Auto;
+      "sh", "Configure from the shell", state.network = Some Shell;
     ]
-    );
-    Some state
+    with
+    | Yes ("auto"::_) -> Next { state with network = Some Auto }
+    | Yes ("sh"::_) -> Next { state with network = Some Shell }
+    | Yes _ | No | Help | Error -> Ask_again
+    | Back -> Prev
+  in
 
-  and ask_hostname state =
-    ignore ( (* XXX *)
-      dialog [
-	title "Remote host" ~cancel:false ~backbutton:true ();
-	inputbox "Remote host" 10 50 (default "" state.remote_host)
-      ]
-    );
-    Some state
+  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 ->
+	(string_of_int i, dev_of_partition part,
+	 Some part = state.root_filesystem)
+    ) all_partitions in
+    match
+    radiolist "Root device"
+      "Pick partition containing the root (/) filesystem" 15 50 6
+      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
 
-  and ask_port state =
-    ignore ( (* XXX *)
-      dialog [
-	title "Remote port" ~cancel:false ~backbutton:true ();
-	inputbox "Remote port" 10 50 (default "" state.remote_port)
+  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
       ]
-    );
-    Some state
+    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 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", "Other or auto-detect",
+        state.architecture = None || state.architecture = Some "";*)
+    ]
+    with
+    | Yes (("auto"|"")::_ | []) -> Next { state with architecture = Some "" }
+    | Yes (arch :: _) -> Next { state with architecture = Some arch }
+    | No | Help | Error -> Ask_again
+    | Back -> Prev
+  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 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 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
 
+  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.
+
+Connection:   %s
+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"
+	 (match state.transport with
+	  | Some Server -> "Server" | Some SSH -> "SSH"
+	  | None -> "")
+         (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"
+	  | 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 "" -> "Guess" | Some arch -> 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 -> "")
+      )
+      21 50
+    with
+    | Yes _ -> Next state
+    | Back -> Prev
+    | No | Help | Error -> Ask_again
   in
 
   (* This is the list of dialogs, in order.  The user can go forwards or
@@ -177,21 +843,31 @@ let rec main ttyname =
     ask_greeting,			(* Initial greeting. *)
       defaults.greeting;
     ask_transport,			(* Transport (ssh, tcp) *)
-      defaults.remote_transport = None;
+      defaults.transport = None;
     ask_hostname,			(* Hostname. *)
       defaults.remote_host = None;
     ask_port,				(* Port number. *)
       defaults.remote_port = None;
-(*    ask_directory,			(* Remote directory. *)
+    ask_directory,			(* Remote directory. *)
       defaults.remote_directory = None;
+    ask_network,			(* Network configuration. *)
+      defaults.network = None;
     ask_devices,			(* Block devices to send. *)
       defaults.devices_to_send = None;
     ask_root,				(* Root filesystem. *)
       defaults.root_filesystem = None;
-    ask_network,			(* Network configuration. *)
-      defaults.network = None;
+    ask_hypervisor,			(* Hypervisor. *)
+      defaults.hypervisor = None;
+    ask_architecture,			(* Architecture. *)
+      defaults.architecture = None;
+    ask_memory,				(* Memory. *)
+      defaults.memory = None;
+    ask_vcpus,				(* VCPUs. *)
+      defaults.vcpus = None;
+    ask_mac_address,			(* MAC address. *)
+      defaults.mac_address = None;
     ask_verify,				(* Verify settings. *)
-      defaults.greeting*)
+      defaults.greeting
   |] in
 
   (* Loop through the dialogs until we reach the end. *)
@@ -205,13 +881,11 @@ let rec main ttyname =
 	(* Skip this dialog and move straight to the next one. *)
 	loop (posn+1) state
       else (
-	(* Run dialog.  Either the state is updated or 'None' is
-	 * returned, which indicates that the user hit the back button.
-	 *)
-	let next_state = dlg state in
-	match next_state with
-	| Some state -> loop (posn+1) state (* Forwards. *)
-	| None -> loop (posn-1) state	    (* Backwards. *)
+	(* Run dialog. *)
+	match dlg state with
+	| Next new_state -> loop (posn+1) new_state (* Forwards. *)
+	| Prev -> loop (posn-1) state	    (* Backwards / back button. *)
+	| Ask_again -> loop posn state	    (* Repeat the question. *)
       )
     )
   in
@@ -219,67 +893,463 @@ let rec main ttyname =
 
   eprintf "finished dialog loop\n%!";
 
+  (* Check that the environment is a sane-looking live CD.  If not, bail. *)
+  if is_dir "/mnt/root" <> Some true then
+    fail_dialog "You should only run this script from the live CD or a USB key.";
 
+  (* Switch LVM config. *)
+  sh "vgchange -a n";
+  putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
+  sh "rm -f /etc/lvm/cache/.cache";
+  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 =
+    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
 
+  (* Run kpartx on the snapshots. *)
+  List.iter (
+    fun (origin, snapshot) ->
+      shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
+  ) devices_to_send;
 
+  (* 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
+   | Part (dev, partnum) ->
+       let dev = dev ^ partnum in
+       let snapshot_dev = snapshot_name dev in
+       sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
 
-(* Run the external 'dialog' command with the given list of parameters.
- * Actually it's a list-of-list-of-parameters because you would normally
- * use this function like this:
- *   dialog [
- *     title (* title and other common parameters *) ();
- *     dialogtype (* specific parameter *)
- *   ]
- * where 'dialogtype' is a function such as 'msgbox' (see below)
- * representing a specific subfunction of dialog.
- *
- * The functions 'title' and 'dialogtype' return partially-constructed
- * lists of shell parameters.  See the dialog manpage.
- *
- * Returns the exit status (Yes | No | Help | Extra | Error).
- *)
-and dialog params =
-  let params = List.concat params in	(* list-of-list to flat list *)
-  let params = List.map Filename.quote params in (* shell quoting *)
-  let cmd = String.concat " " ("dialog" :: params) in
-  eprintf "%s\n%!" cmd;			(* log the full command *)
-  let r = Sys.command cmd in
-  match r with
-  | 0 -> Yes | 1 -> No | 2 -> Help | 3 -> Extra | _ -> Error
-
-(* Title and common dialog options. *)
-and title title ?(cancel=true) ?(backbutton=false) () =
-  let params = ["--title"; title] in
-  let params = if not cancel then "--nocancel" :: params else params in
-  let params =
-    if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
-    else params in
-  params
-
-(* Message box. *)
-and msgbox text height width =
-  [ "--msgbox"; text; string_of_int height; string_of_int width ]
-
-and inputbox text height width default =
-  [ "--inputbox"; text; string_of_int height; string_of_int width; default ]
-
-and radiolist text height width listheight items =
-  let items = List.map (
-    function
-    | tag, item, true -> [ tag; item; "on" ]
-    | tag, item, false -> [ tag; item; "off" ]
-  ) items in
-  let items = List.concat items in
-  "--radiolist" :: text :: string_of_int height :: string_of_int width ::
-    string_of_int listheight :: items
+   | LV (vg, lv) ->
+       (* The LV will be backed by a snapshot device, so just mount
+	* directly.
+	*)
+       sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
+  );
+
+  (* See if we can do network configuration. *)
+  let network = Option.get state.network in
+  (match network with
+   | Shell ->
+       printf "Network configuration.\n\n";
+       printf "Please configure the network from this shell.\n\n";
+       printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
+       shell ()
+
+   | Auto ->
+       printf
+	 "Trying network auto-configuration from root filesystem ...\n\n%!";
+       if not (auto_network state) then (
+	 printf "\nAuto-configuration failed.  Starting a shell.\n\n";
+	 printf "Please configure the network from this shell.\n\n";
+	 printf "When you have finished, exit the shell with ^D or exit.\n\n";
+	 shell ()
+       )
+  );
+
+  (* Work out what devices will be called at the remote end. *)
+  let 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)
+  ) devices_to_send in
+
+  (* Modify files on the root filesystem. *)
+  rewrite_fstab state devices_to_send;
+  (* XXX Other files to rewrite? *)
+
+  (* XXX Autodetect architecture of root filesystem by looking for /bin/ls. *)
+  let system_architecture = "x86_64" in
+
+  (* XXX Autodetect system memory. *)
+  let system_memory = 256 in
+
+  (* XXX Autodetect system # pCPUs. *)
+  let system_nr_cpus = 1 in
+
+  (* Unmount the root filesystem and sync disks. *)
+  sh "umount /mnt/root";
+  sh "sync";				(* Ugh, should be in stdlib. *)
+
+  (* Disable screen blanking on console. *)
+  sh "setterm -blank 0";
+
+  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 transport = Option.get state.transport in
+
+  (* Connect and disconnect from the remote system. *)
+  let do_connect, do_disconnect =
+    match transport with
+    | Server ->
+	let do_connect remote_name size =
+	  let addrs =
+	    getaddrinfo remote_host remote_port [AI_SOCKTYPE SOCK_STREAM] in
+	  let rec loop = function
+	    | [] ->
+		fail_dialog
+		  (sprintf "Unable to connect to %s:%s" remote_host remote_port)
+	    | addr :: addrs ->
+		try
+		  let sock =
+		    socket addr.ai_family addr.ai_socktype addr.ai_protocol in
+		  connect sock addr.ai_addr;
+		  let header = sprintf "p2v2 %s %Ld\n%!" remote_name size in
+		  let len = String.length header in
+		  assert (len = write sock header 0 len);
+		  sock
+		with Unix_error (err, syscall, extra) ->
+		  (* Log the error message, but continue around the loop. *)
+		  eprintf "%s:%s: %s\n%!" syscall extra (error_message err);
+		  loop addrs
+	  in
+	  loop addrs
+	in
+	let do_disconnect sock = close sock in
+	do_connect, do_disconnect
+    | SSH ->
+	(* Cheat by keeping a private variable around containing the original
+	 * channel, so we can close it easily. (XXX)
+	 *)
+	let chan = ref None in
+	let do_connect remote_name _ =
+	  let cmd = sprintf "ssh -C -p %s %s \"cat > %s/%s\""
+	    (quote remote_port) (quote remote_host)
+	    (quote remote_directory) (quote remote_name) in
+	  let c = open_process_out cmd in
+	  chan := Some c;
+	  descr_of_out_channel c
+	in
+	let do_disconnect _ =
+	  (match close_process_out (Option.get !chan) with
+	   | WEXITED 0 -> ()		(* OK *)
+	   | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
+	   | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
+	   | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
+	  );
+	  chan := None
+	in
+	do_connect, do_disconnect in
+
+  (* XXX This is using the hostname derived from network configuration
+   * above.  We might want to ask the user to choose.
+   *)
+  let hostname = safe_name (gethostname ()) in
+  let basename =
+    let date = sprintf "%04d%02d%02d%02d%02d"
+      (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
+    "p2v-" ^ hostname ^ "-" ^ date in
+
+  (* Work out what the image filenames will be at the remote end. *)
+  let 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)
+  ) 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
+   * always get well-formed XML.
+   *
+   * XXX For some of the stuff here we really should do a
+   * virConnectGetCapabilities call to the remote host first.
+   *
+   * XXX There is a case for using virt-install to generate this XML.
+   * When we start to incorporate libvirt access & storage API this
+   * needs to be rethought.
+   *)
+  let conf_filename = basename ^ ".conf" in
+
+  let architecture =
+    match state.architecture with
+    | Some "" | None -> system_architecture
+    | Some arch -> arch in
+  let memory =
+    match state.memory with
+    | Some memory -> memory
+    | None -> system_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 ->
+	let random =
+	  List.map (sprintf "%02x") (
+	    List.map (fun _ -> Random.int 256) [0;0;0]
+	  ) in
+	String.concat ":" ("00"::"16"::"3e"::random)
+    | Some mac -> mac in
+
+  let xml =
+    (* Shortcut to make "<name>value</name>". *)
+    let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
+    (* ... and the _other_ sort of leaf (god I hate XML). *)
+    let tleaf name attribs = Xml.Element (name, attribs, []) in
+
+    (* Standard stuff for every domain. *)
+    let name = leaf "name" hostname in
+    let memory = leaf "memory" (string_of_int (memory * 1024)) in
+    let vcpu = leaf "vcpu" (string_of_int vcpus) in
+
+    (* Top-level stuff which differs for each HV type (isn't this supposed
+     * to be portable ...)
+     *)
+    let extras =
+      match state.hypervisor with
+      | Some Xen ->
+	  [Xml.Element ("os", [],
+			[leaf "type" "hvm";
+			 leaf "loader" "/usr/lib/xen/boot/hvmloader";
+			 tleaf "boot" ["dev", "hd"]]);
+	   Xml.Element ("features", [],
+			[tleaf "pae" [];
+			 tleaf "acpi" [];
+			 tleaf "apic" []]);
+	   tleaf "clock" ["sync", "localtime"]]
+      | Some KVM ->
+	  [Xml.Element ("os", [], [leaf "type" "hvm"]);
+	   tleaf "clock" ["sync", "localtime"]]
+      | Some QEMU ->
+	  [Xml.Element ("os", [],
+			[Xml.Element ("type", ["arch",architecture;
+					       "machine","pc"],
+				      [Xml.PCData "hvm"]);
+			 tleaf "boot" ["dev", "hd"]])]
+      | None ->
+	  [] in
+
+    (* <devices> section. *)
+    let devices =
+      let emulator =
+	match state.hypervisor with
+	| Some Xen ->
+	    [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
+	| Some QEMU ->
+	    [leaf "emulator" "/usr/bin/qemu"]
+	| Some KVM ->
+	    [leaf "emulator" "/usr/bin/qemu-kvm"]
+	| None ->
+	    [] in
+      let interface =
+	Xml.Element ("interface", ["type", "user"],
+		     [tleaf "mac" ["address", mac_address]]) in
+      (* XXX should have an option for Xen bridging:
+	Xml.Element (
+	"interface", ["type","bridge"],
+	[tleaf "source" ["bridge","xenbr0"];
+	tleaf "mac" ["address",mac_address];
+	tleaf "script" ["path","vif-bridge"]])*)
+      let graphics = tleaf "graphics" ["type", "vnc"] in
+
+      let disks = List.map (
+	fun (_, _, remote_dev, remote_name) ->
+	  Xml.Element (
+	    "disk", ["type", "file";
+		     "device", "disk"],
+	    [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
+	     tleaf "target" ["dev", remote_dev]]
+	  )
+      ) devices_to_send in
+
+      Xml.Element (
+	"devices", [],
+	emulator @ interface :: graphics :: disks
+      ) in
+
+    (* Put it all together in <domain type='foo'>. *)
+    Xml.Element (
+      "domain",
+      (match state.hypervisor with
+       | Some Xen -> ["type", "xen"]
+       | Some QEMU -> ["type", "qemu"]
+       | Some KVM -> ["type", "kvm"]
+       | None -> []),
+      name :: memory :: vcpu :: extras @ [devices]
+    ) in
+
+  let xml = Xml.to_string_fmt xml in
+  let xml_len = String.length xml in
+  eprintf "length of configuration file is %d bytes\n%!" xml_len;
+
+  let sock = do_connect conf_filename (Int64.of_int xml_len) in
+  (* In OCaml this actually loops calling write(2) *)
+  ignore (write sock xml 0 xml_len);
+  do_disconnect sock;
+
+  (* Send the device snapshots to the remote host. *)
+  (* XXX This code should be made more robust against both network
+   * errors and local I/O errors.  Also should allow the user several
+   * attempts to connect, or let them go back to the dialog stage.
+   *)
+  List.iter (
+    fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
+      eprintf "sending %s as %s\n%!" origin_dev remote_name;
+
+      let size =
+	try List.assoc origin_dev all_block_devices
+	with Not_found -> assert false (* internal error *) in
+
+      printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
+	((Int64.to_float size) /. (1024.*.1024.*.1024.));
+
+      (* Open the snapshot device. *)
+      let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
+
+      (* Now connect. *)
+      let sock = do_connect remote_name size in
+
+      (* Copy the data. *)
+      let bufsize = 1024 * 1024 in
+      let buffer = String.create bufsize in
+      let start = gettimeofday () in
+
+      let rec copy bytes_sent last_printed_at =
+	let n = read fd buffer 0 bufsize in
+	if n > 0 then (
+	  ignore (write sock buffer 0 n);
+
+	  let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
+	  let last_printed_at =
+	    let now = gettimeofday () in
+	    (* Print progress once per second. *)
+	    if now -. last_printed_at > 1. then (
+	      let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
+	      let secs_elapsed = now -. start in
+	      printf "%.0f%%" (100. *. elapsed);
+	      (* After 60 seconds has elapsed, start printing estimates. *)
+	      if secs_elapsed >= 60. then (
+		let remaining = 1. -. elapsed in
+		let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
+		if secs_remaining > 120. then
+		  printf " (about %.0f minutes remaining)          "
+		    (secs_remaining /. 60.)
+		else
+		  printf " (about %.0f seconds remaining)          "
+		    secs_remaining
+	      );
+	      printf "\r%!";
+	      now
+	    )
+	    else last_printed_at in
+
+	  copy bytes_sent last_printed_at
+	)
+      in
+      copy 0L start;
+
+      (* Disconnect. *)
+      do_disconnect sock
+  ) devices_to_send;
+
+  (* Clean up and reboot. *)
+  ignore (
+    msgbox "virt-p2v completed"
+      (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
+  );
+
+  shfailok "eject";
+  shfailok "reboot";
+  exit 0
 
 let usage () =
   eprintf "usage: virt-p2v [ttyname]\n%!";
   exit 2
 
+(* Make sure that exceptions from 'main' get printed out on stdout
+ * as well as stderr, since stderr is probably redirected to the
+ * logfile, and so not visible to the user.
+ *)
+let handle_exn f arg =
+  try f arg
+  with exn -> print_endline (Printexc.to_string exn); raise exn
+
+(* If the ISO image has an attachment then it could be a new version
+ * of virt-p2v.ml (this script).  Get the attachment and run it
+ * instead.  Useful mainly for testing, in conjunction with the
+ * 'make update' target in the virt-p2v Makefile.
+ *)
+let magic = "ISOATTACHMENT002"
+let magiclen = String.length magic  (* = 16 bytes *)
+let trailerlen = magiclen + 8 + 8   (* magic + file start + true size *)
+
+let int64_of_string str =
+  let i = ref 0L in
+  let add offs shift =
+    i :=
+      Int64.logor
+	(Int64.shift_left (Int64.of_int (Char.code str.[offs])) shift) !i
+  in
+  add 0 56;  add 1 48;  add 2 40;  add 3 32;
+  add 4 24;  add 5 16;  add 6 8;   add 7 0;
+  !i
+
+let update ttyname =
+  let cdrom = "/dev/cdrom" in
+  let output = "/tmp/virt-p2v.ml" in
+
+  try
+    let fd = openfile cdrom [O_RDONLY] 0 in
+    ignore (LargeFile.lseek fd (Int64.of_int ~-trailerlen) SEEK_END);
+    let buf = String.create magiclen in
+    if read fd buf 0 magiclen <> magiclen || buf <> magic then (
+      close fd;
+      raise Exit
+    );
+
+    (* Read the size. *)
+    let buf = String.create 8 in
+    if read fd buf 0 8 <> 8 then
+      failwith "cannot read attachment offset";
+    let offset = int64_of_string buf in
+    let buf = String.create 8 in
+    if read fd buf 0 8 <> 8 then
+      failwith "cannot read attachment size";
+    let size = Int64.to_int (int64_of_string buf) in
+
+    (* Seek to beginning of the attachment. *)
+    ignore (LargeFile.lseek fd offset SEEK_SET);
+
+    (* Copy out the attachment. *)
+    let fd2 = openfile output [O_WRONLY; O_CREAT; O_TRUNC] 0o755 in
+    let bufsize = 4 * 1024 in
+    let buffer = String.create bufsize in
+    let rec copy remaining =
+      if remaining > 0 then (
+	let n = min remaining bufsize in
+	let n = read fd buffer 0 n in
+	if n = 0 then failwith "corrupted or partial attachment";
+	ignore (write fd2 buffer 0 n);
+	copy (remaining - n)
+      )
+    in
+    copy size;
+    close fd2;
+
+    close fd;
+
+    (* Run updated virt-p2v script. *)
+    execv output [| output; ttyname |]
+  with
+    Unix_error _ | Exit ->
+      (* Some error, or no attachment, so keep running this script. *)
+      handle_exn main (Some ttyname)
+
 (* Test harness for the Makefile.  The Makefile invokes this script as
  * 'virt-p2v.ml --test' just to check it compiles.  When it is running
  * from the actual live CD, there is a single parameter which is the
@@ -287,8 +1357,14 @@ let usage () =
  *)
 let () =
   match Array.to_list Sys.argv with
-  | [ _; "--test" ] -> ()	     (* Makefile test - do nothing. *)
+  | [ _; "--test" ] -> ()	        (* Makefile test - do nothing. *)
+  | [ _; "--update"; ttyname ] ->	(* Test for update and run. *)
+      update ttyname
   | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
-  | [ _; ttyname ] -> main (Some ttyname) (* Run main with ttyname. *)
-  | [ _ ] -> main None		       (* Interactive - no ttyname. *)
+  | [ _; ttyname ] ->			(* Run main with ttyname. *)
+      handle_exn main (Some ttyname)
+  | [ _ ] ->			        (* Interactive - no ttyname. *)
+      handle_exn main None
   | _ -> usage ()
+
+(* This file must end with a newline *)