* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
-type partition =
- | Part of string * string (* eg. "hda", "1" *)
- | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
type transfer =
| P2V (* physical to virtual *)
| V2V (* virtual to virtual *)
(*| V2P*) (* virtual to physical - not impl *)
+type block_device =
+ | HD of string (* eg. HD "a" for /dev/hda *)
+ | SD of string (* eg. SD "b" for /dev/sdb *)
+ | CCISS of int * int (* eg. CCISS (0,0) for /dev/cciss/c0d0*)
+type partition =
+ | Part of block_device * string (* eg. (HD "a", "1")
+ or (CCISS (0,0), "p1") *)
+ | LV of string * string (* eg. ("VolGroup00", "LogVol00") *)
type network =
| Auto of partition (* Automatic network configuration. *)
| Shell (* Start a shell. *)
(* What to transfer. *)
let config_devices_to_send = ref None
+
+(* The root filesystem - parts of this get modified after migration. *)
let config_root_filesystem = ref None
(* Configuration of the target. *)
(* Load external libraries. *)
;;
-#load "unix.cma";;
-#directory "+extlib";;
-#load "extLib.cma";;
-#directory "+pcre";;
-#load "pcre.cma";;
-#directory "+newt";;
-#load "mlnewt.cma";;
-#directory "+xml-light";;
-#load "xml-light.cma";;
-#directory "+libvirt";;
-#load "mllibvirt.cma";;
+#use "topfind";;
+#require "extlib";;
+#require "pcre";;
+#require "newt";;
+#require "xml-light";;
+#require "gettext-stub";;
+#require "libvirt";;
open Unix
open Printf
open ExtString
(*----------------------------------------------------------------------*)
+(* Gettext support.
+ *
+ * Use s_ "string" to mark a translatable string, and f_ "string %s"
+ * to mark a format string (eg. for printf). There are other
+ * functions: see ocaml-gettext manual and GNU gettext info.
+ *
+ * Try not to mark strings which always go to the log file (eg.
+ * eprintf messages).
+ *)
+
+module P2VGettext = Gettext.Program (
+ struct
+ let textdomain = "virt-p2v"
+ let codeset = None
+ let dir = None
+ let dependencies = []
+ end
+) (GettextStub.Native)
+open P2VGettext
+
+let supported_langs =
+ (* Note these strings are NOT translated! *)
+ let nonasian_langs = [
+ "English", "en_US.UTF-8";
+ ] in
+ let asian_langs = [
+ "\xE6\x97\xA5\xE6\x9C\xAC\xE8\xAA\x9E (Japanese)", "ja_JP.UTF-8"
+ ] in
+ (* Linux console doesn't support Asian or RTL languages. *)
+ let term = try getenv "TERM" with Not_found -> "" in
+ match term with
+ | "linux" -> nonasian_langs
+ | _ -> nonasian_langs @ asian_langs
+
+(*----------------------------------------------------------------------*)
(* General helper functions. *)
let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
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
+(* eg. HD "a" => "hda", or CCISS (0,1) => "cciss/c0d1" *)
+let short_dev_of_block_device = function
+ | HD n -> sprintf "hd%s" n
+ | SD n -> sprintf "sd%s" n
+ | CCISS (c, d) -> sprintf "cciss/c%dd%d" c d
+
+(* Returns the full /dev/ path to a block device. *)
+let dev_of_block_device dev = "/dev/" ^ short_dev_of_block_device dev
+
+(* Returns path to partition or LV without /dev/,
+ * eg. "hda1" or "VolGroup/LogVol"
+ *)
+let short_dev_of_partition = function
+ | Part (dev, partnum) -> short_dev_of_block_device dev ^ partnum
+ | LV (vg, lv) -> sprintf "%s/%s" vg lv
+
+(* Returns the full /dev/ path to a partition or LV. *)
+let dev_of_partition part = "/dev/" ^ short_dev_of_partition part
+
+(* A PV is loosely defined here as either a device or a partition -
+ * basically anything that could be a PV.
+ *)
+type pv = PVDev of block_device | PVPart of partition
+
+let string_of_pv = function
+ | PVDev dev -> dev_of_block_device dev
+ | PVPart p -> dev_of_partition p
+
+(* Take a device name optionally beginning with /dev/ and work
+ * out if it looks like either a device or partition that we
+ * know how to deal with. If not, returns None.
+ *
+ * For the sake of simplifying some code later on, the device
+ * name may also be followed by "(\d+)" which is just ignored.
+ *)
+let pv_of_dev =
+ let hdp = Pcre.regexp "^/dev/hd([a-z]+)(\\d+)(\\(\\d+\\))?$" in
+ let hd = Pcre.regexp "^/dev/hd([a-z]+)(\\(\\d\\))?$" in
+ let sdp = Pcre.regexp "^/dev/sd([a-z]+)(\\d+)(\\(\\d+\\))?$" in
+ let sd = Pcre.regexp "^/dev/sd([a-z]+)(\\(\\d+\\))?$" in
+ let ccissp = Pcre.regexp "^/dev/cciss/c(\\d+)d(\\d+)(p\\d+)(\\(\\d+\\))?$" in
+ let cciss = Pcre.regexp "^/dev/cciss/c(\\d+)d(\\d+)(\\(\\d+\\))?$" in
+ let lv = Pcre.regexp "^/dev/(\\w+)/(\\w+)$" in
+
+ fun name ->
+ try
+ let subs = Pcre.exec ~rex:hdp name in
+ Some (PVPart (Part (HD (Pcre.get_substring subs 1),
+ Pcre.get_substring subs 2)))
+ with Not_found ->
+ try
+ let subs = Pcre.exec ~rex:hd name in
+ Some (PVDev (HD (Pcre.get_substring subs 1)))
+ with Not_found ->
+ try
+ let subs = Pcre.exec ~rex:sdp name in
+ Some (PVPart (Part (SD (Pcre.get_substring subs 1),
+ Pcre.get_substring subs 2)))
+ with Not_found ->
+ try
+ let subs = Pcre.exec ~rex:sd name in
+ Some (PVDev (SD (Pcre.get_substring subs 1)))
+ with Not_found ->
+ try
+ let subs = Pcre.exec ~rex:ccissp name in
+ let c = int_of_string (Pcre.get_substring subs 1) in
+ let d = int_of_string (Pcre.get_substring subs 2) in
+ Some (PVPart (Part (CCISS (c, d), Pcre.get_substring subs 3)))
+ with Not_found ->
+ try
+ let subs = Pcre.exec ~rex:cciss name in
+ let c = int_of_string (Pcre.get_substring subs 1) in
+ let d = int_of_string (Pcre.get_substring subs 2) in
+ Some (PVDev (CCISS (c, d)))
+ with Not_found ->
+ try
+ let subs = Pcre.exec ~rex:lv name in
+ let vg = Pcre.get_substring subs 1 in
+ let lv = Pcre.get_substring subs 2 in
+ Some (PVPart (LV (vg, lv)))
+ with Not_found ->
+ None
let string_of_architecture = function
| I386 -> "i386"
| OtherArch arch -> arch
| UnknownArch -> ""
+let architecture_of_string = function
+ | str when
+ String.length str = 4 &&
+ (str.[0] = 'i' || str.[0] = 'I') &&
+ (str.[1] >= '3' && str.[1] <= '6') &&
+ str.[2] = '8' && str.[3] = '6' -> I386
+ | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64
+ | "ia64" | "IA64" -> IA64
+ | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC
+ | "ppc64" | "PPC64" -> PPC64
+ | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC
+ | "sparc64" | "SPARC64" -> SPARC64
+ | "" -> UnknownArch
+ | str -> OtherArch str
+
+type wordsize =
+ | W32 | W64 | WUnknown
+
+let wordsize_of_architecture = function
+ | I386 -> W32
+ | X86_64 -> W64
+ | IA64 -> W64
+ | PPC -> W32
+ | PPC64 -> W64
+ | SPARC -> W32
+ | SPARC64 -> W64
+ | OtherArch arch -> WUnknown
+ | UnknownArch -> WUnknown
+
type nature = LinuxSwap
| LinuxRoot of architecture * linux_distro
| WindowsRoot (* Windows C: *)
| OtherLinux
let rec string_of_nature = function
- | LinuxSwap -> "Linux swap"
+ | LinuxSwap -> s_ "Linux swap"
| LinuxRoot (architecture, distro) ->
string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
- | WindowsRoot -> "Windows root"
- | LinuxBoot -> "Linux /boot"
- | NotRoot -> "Mountable non-root"
- | UnknownNature -> "Unknown"
+ | WindowsRoot -> s_ "Windows root"
+ | LinuxBoot -> s_ "Linux /boot"
+ | NotRoot -> s_ "Mountable non-root"
+ | UnknownNature -> s_ "Unknown partition type"
and string_of_linux_distro = function
| RHEL (a,b) -> sprintf "RHEL %d.%d" a b
| Fedora v -> sprintf "Fedora %d" v
| Debian (a,b) -> sprintf "Debian %d.%d" a b
| OtherLinux -> "Linux"
+(* XML helper functions. *)
+let rec children_with_name name xml =
+ let children = Xml.children xml in
+ List.filter (
+ function
+ | Xml.Element (n, _, _) when n = name -> true
+ | _ -> false
+ ) children
+and xml_has_pcdata_child name pcdata xml =
+ xml_has_child_matching (
+ function
+ | Xml.Element (n, _, [Xml.PCData pcd])
+ when n = name && pcd = pcdata -> true
+ | _ -> false
+ ) xml
+and xml_has_attrib_child name attrib xml =
+ xml_has_child_matching (
+ function
+ | Xml.Element (n, attribs, _)
+ when n = name && List.mem attrib attribs -> true
+ | _ -> false
+ ) xml
+and xml_has_child_matching f xml =
+ let children = Xml.children xml in
+ List.exists f children
+and find_child_with_name name xml =
+ let children = children_with_name name xml in
+ match children with
+ | [] -> raise Not_found
+ | h :: _ -> h
+and find_pcdata_child name xml =
+ let children = children_with_name name xml in
+ let rec loop = function
+ | [] -> raise Not_found
+ | Xml.Element (_, _, [Xml.PCData pcd]) :: _ -> pcd
+ | _ :: tl -> loop tl
+ in
+ loop children
+
type ('a, 'b) either = Either of 'a | Or of 'b
(* We go into and out of newt mode at various stages, but we might
* and help messages are consistent.
*)
let open_centered_window ?stage width height title =
- if not !in_newt then failwith "open_centered_window: not in newt mode";
+ if not !in_newt then failwith (s_ "open_centered_window: not in newt mode");
Newt.cls ();
Newt.centered_window width height title;
let root_text =
| None -> ""
| Some stage -> " - " ^ stage) in
Newt.draw_root_text 0 0 root_text;
- Newt.push_help_line "F12 for next screen | [ALT] [F2] root / no password for shell"
+ Newt.push_help_line
+ (s_ "F12 for next screen | [ALT] [F2] root / no password for shell")
+
+let ok_button = " OK "
(* Some general dialog boxes. *)
let message_box title text =
let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
Newt.textbox_set_text textbox text;
- let ok = Newt.button 28 16 " OK " in
+ let ok = Newt.button 28 16 ok_button in
let form = Newt.form None None [] in
Newt.form_add_components form [textbox; ok];
(* Fail and exit with error. *)
let failwith text =
prerr_endline 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
- message_box "Error" text;
+ let text = "\n"
+ ^ text
+ ^ s_ "\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
+ message_box (s_ "Error") text;
exit 1
(* Display a dialog with checkboxes, return the multiple selected items. *)
(handle, cb)
) items in
- let ok = Newt.button 48 16 " OK " in
+ let ok = Newt.button 48 16 ok_button in
let vb =
if List.length entries > 10 then
(handle, rb)
) items in
- let ok = Newt.button (width-12) 16 " OK " in
+ let ok = Newt.button (width-12) 16 ok_button in
let vb =
if List.length entries > 10 then
(* Run a shell command and check it returns 0. *)
let sh cmd =
eprintf "sh: %s\n%!" cmd;
- if Sys.command cmd <> 0 then failwith (sprintf "Command failed:\n\n%s" cmd)
+ if Sys.command cmd <> 0 then
+ failwith (sprintf (f_ "Command failed:\n\n%s") cmd)
let shfailok cmd =
eprintf "shfailok: %s\n%!" cmd;
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)
+ | WSIGNALED i ->
+ failwith (sprintf (f_ "shget: command killed by signal %d") i)
+ | WSTOPPED i ->
+ failwith (sprintf (f_ "shget: command stopped by signal %d") i)
(* Start an interactive shell. Need to juggle file descriptors a bit
* because bash write PS1 to stderr (currently directed to the logfile).
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).
+ * corresponding PVs, etc.
+ *
+ * Returns a list of LVs, and a list of PVs.
*)
-let get_lvs =
- let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
-
- fun () ->
- match
- shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
- with
- | None -> []
- | Some lines ->
- let lines = List.map Pcre.split lines in
+let get_lvs () =
+ match
+ shget "lvs --noheadings -o vg_name,lv_name,devices"
+ with
+ | None -> [], []
+ | Some lines ->
+ let all_pvs = ref [] in
+ let lines = List.map Pcre.split lines in
+ let lvs =
List.map (
function
- | [vg; lv; pvs; lvsize]
- | [_; vg; lv; pvs; lvsize] ->
+ | [vg; lv; pvs] | [_; vg; lv; pvs] ->
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
+ let pvs = List.filter_map pv_of_dev pvs in
+ all_pvs := !all_pvs @ pvs;
+ LV (vg, lv)
| line ->
- failwith ("lvs: unexpected output: " ^ String.concat "," line)
- ) lines
+ failwith ("lvs: " ^ s_ "unexpected output: " ^
+ String.concat "," line)
+ ) lines in
+ lvs, sort_uniq !all_pvs
+
+(* Get all block devices attached to the system. Also queries and
+ * returns the size in bytes of each. It tries to ignore any
+ * removable block devices like CD-ROMs.
+ *)
+let get_all_block_devices () =
+ let sys_block_entries =
+ List.sort (Array.to_list (Sys.readdir "/sys/block")) in
+
+ let get name filter =
+ let devices = List.filter_map filter sys_block_entries in
+ eprintf "get_all_block_devices: %s: block devices: %s\n%!"
+ name (String.concat "; " (List.map dev_of_block_device 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 " ^ (dev_of_block_device 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: %s: non-removable block devices: %s\n%!"
+ name
+ (String.concat "; "
+ (List.map (fun (d, b) ->
+ sprintf "%s [%Ld]" (dev_of_block_device d) b)
+ devices));
+
+ devices
+ in
+
+ (* Search for hdX. *)
+ let rex = Pcre.regexp "^hd([a-z]+)$" in
+ let filter name =
+ try
+ let subs = Pcre.exec ~rex name in
+ Some (HD (Pcre.get_substring subs 1))
+ with
+ Not_found -> None
+ in
+ let devices = get "hd" filter in
+
+ (* Search for sdX. *)
+ let rex = Pcre.regexp "^sd([a-z]+)$" in
+ let filter name =
+ try
+ let subs = Pcre.exec ~rex name in
+ Some (SD (Pcre.get_substring subs 1))
+ with
+ Not_found -> None
+ in
+ let devices = devices @ get "sd" filter in
+
+ (* Search for cciss. *)
+ let rex = Pcre.regexp "^cciss!c(\\d)d(\\d)$" in
+ let filter name =
+ try
+ let subs = Pcre.exec ~rex name in
+ let c = int_of_string (Pcre.get_substring subs 1) in
+ let d = int_of_string (Pcre.get_substring subs 2) in
+ Some (CCISS (c, d))
+ with
+ Not_found -> None
+ in
+ let devices = devices @ get "cciss" filter in
+ devices
(* Get the partitions on a block device.
- * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
+ * eg. SD "a" -> [Part (SD "a","1"); Part (SD "a", "2")]
*)
let get_partitions dev =
- let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
- let devdir = "/sys/block/" ^ dev in
- let parts = Sys.readdir devdir in
+ (* Read the device directory, eg. /sys/block/hda, which we expect
+ * to contain partition devices like /sys/block/hda/hda1 etc.
+ *)
+ let subdir, rex =
+ match dev with
+ | HD n -> "hd" ^ n, sprintf "^hd%s(.+)$" n
+ | SD n -> "sd" ^ n, sprintf "^sd%s(.+)$" n
+ | CCISS (c,d) ->
+ sprintf "cciss!c%dd%d" c d, sprintf "^cciss!c%dd%d(p.+)$" c d in
+ let rex = Pcre.regexp rex in
+ let dir = "/sys/block/" ^ subdir in
+ let parts = Sys.readdir dir in
let parts = Array.to_list parts in
let parts = List.filter (
- fun name -> Some true = is_dir (devdir ^ "/" ^ name)
+ fun name -> is_dir (dir ^ "/" ^ name) = Some true
) parts in
let parts = List.filter_map (
fun part ->
(* Generate snapshot device name from device name. *)
let snapshot_name dev =
- "snap" ^ (safe_name dev)
+ "snap" ^ (safe_name (short_dev_of_block_device dev))
(* Perform a device-mapper snapshot with ramdisk overlay. *)
let snapshot =
in
fun origin_dev snapshot_dev ->
let ramdisk = next_free_ram_disk () in
+ let origin_dev = dev_of_block_device origin_dev in
let sectors =
- let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
+ let cmd = "blockdev --getsz " ^ (quote origin_dev) in
let lines = shget cmd in
match lines with
| Some (sectors::_) -> Int64.of_string sectors
| Some [] | None ->
- failwith (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
+ failwith (sprintf (f_ "Disk 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'"
+ sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin %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'"
shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`";
if !config_greeting then (
- printf "\n\nDid automatic network configuration work?\n";
- printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
+ print_endline (s_ "\n\nDid automatic network configuration work?\nHint: If not sure, there is a shell on console [ALT] [F2]");
printf " (y/n) %!";
let line = read_line () in
String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
sh "route add default gw 10.0.2.2 eth0";
sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
-(* 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
-
(* Make an SSH connection to the remote machine, execute command.
* The connection remains open until you call ssh_disconnect, it
* times out or there is some error.
eprintf "ssh_disconnect\n%!";
match close_process_out 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)
+ | WEXITED i -> failwith (sprintf (f_ "ssh: exited with error code %d") i)
+ | WSIGNALED i -> failwith (sprintf (f_ "ssh: killed by signal %d") i)
+ | WSTOPPED i -> failwith (sprintf (f_ "ssh: stopped by signal %d") i)
(* Use these functions to upload a file. *)
let ssh_start_upload config filename =
(* Test SSH connection. *)
let test_ssh config =
- printf "Testing SSH connection by listing files in remote directory ...\n\n%!";
+ print_endline
+ (s_ "Testing SSH connection by listing files in remote directory ...\n");
let cmd = sprintf "/bin/ls %s" (quote config.ssh_directory) in
let conn = ssh_connect config cmd in
ssh_disconnect conn;
if !config_greeting then (
- printf "\n\nDid SSH work?\n";
- printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
+ print_endline (s_ "\n\nDid SSH work?\nHint: 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')
true
(* Rewrite /mnt/root/etc/fstab. *)
-let rewrite_fstab devices_to_send =
+let rewrite_fstab remote_map =
let filename = "/mnt/root/etc/fstab" in
if is_file filename = Some true then (
sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
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
+ let remote_dev =
+ match pv_of_dev dev with (* eg. /dev/sda1 where sda is in the map *)
+ | Some (PVPart (Part (pdev, partnum))) ->
+ (try List.assoc pdev remote_map ^ partnum
+ with Not_found -> dev
+ );
+ | Some (PVDev pdev) -> (* eg. /dev/sda *)
+ (try List.assoc pdev remote_map
+ with Not_found -> dev
+ );
+ | _ -> dev in
+ remote_dev :: rest
| line -> line
) lines in
let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
dup2 fd stdin;
dup2 fd stdout;
- close fd);
- printf "%s starting up ...\n%!" program_name;
+ close fd
+ );
+
+ (* Choose language early, so messages are translated. *)
+ if !config_greeting && List.length supported_langs > 1 then (
+ with_newt (
+ fun () ->
+ let lang = select_single ~stage:(s_ "Select language") 40
+ (s_ "Select language")
+ supported_langs in
+
+ putenv "LANG" lang;
+ ignore (GettextStubCompat.setlocale GettextStubCompat.LC_ALL lang)
+ )
+ );
+
+ let () = printf (f_ "%s starting up ...\n%!") program_name in
(* Disable screen blanking on tty. *)
sh "setterm -blank 0";
(* Check that the environment is a sane-looking live CD. If not, bail. *)
if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
failwith
- "You should only run this script from the live CD or a USB key.";
+ (s_ "You should only run this script from the live CD or a USB key.");
(* Start of the information gathering phase. *)
- printf "Detecting hard drives (this may take some time) ...\n%!";
+ print_endline
+ (s_ "Detecting hard drives (this may take some time) ...");
(* 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".
+ * if we can't find anything.
+ *
+ * This is a list of block_device, like HD "a", and size in bytes.
*)
- 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));
+ let all_block_devices : (block_device * int64) list =
+ let devices = get_all_block_devices () in
if devices = [] then
- failwith "No non-removable block devices (hard disks, etc.) could be found on this machine.";
+ failwith
+ (s_ "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
*)
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
+ let lvs, pvs = get_lvs () in
+ eprintf "all_partitions: PVs: %s\n%!"
+ (String.concat "; " (List.map string_of_pv pvs));
+ eprintf "all_partitions: LVs: %s\n%!"
+ (String.concat "; " (List.map dev_of_partition lvs));
+
+ (* For now just ignore any block devices which are PVs. *)
+ let block_devices =
+ List.filter (
+ fun (dev, _) -> not (List.mem (PVDev dev) pvs)
+ ) all_block_devices in
(* Partitions (eg. "sda1", "sda2"). *)
let parts =
- let parts = List.map fst all_block_devices in
+ let parts = List.map fst block_devices in
let parts = List.map get_partitions parts in
let parts = List.concat parts in
eprintf "all_partitions: all partitions: %s\n%!"
(* Remove any partitions which are PVs. *)
let parts = List.filter (
function
- | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
+ | (Part _) as p -> not (List.mem (PVPart p) pvs)
| LV _ -> assert false
) parts in
parts in
(* Concatenate LVs & Parts *)
lvs @ parts in
+ (* Run blockdev --getsize64 on each partition to get its size.
+ *
+ * Returns a list of partitions and their size in bytes.
+ *)
+ let all_partitions : (partition * int64) list =
+ List.filter_map (
+ fun part ->
+ let cmd = "blockdev --getsize64 " ^ quote (dev_of_partition part) in
+ let lines = shget cmd in
+ match lines with
+ | Some (blksize::_) -> Some (part, Int64.of_string blksize)
+ | Some [] | None -> None
+ ) all_partitions in
+
(* Try to determine the nature of each partition.
* Root? Swap? Architecture? etc.
*)
- let all_partitions : (partition * nature) list =
+ let all_partitions : (partition * (int64 * nature)) list =
(* Output of 'file' command for Linux swap file. *)
let swap = Pcre.regexp "Linux.*swap.*file" in
(* Contents of /etc/redhat-release. *)
in
List.map (
- fun part ->
+ fun (part, size) ->
let dev = dev_of_partition part in (* Get /dev device. *)
let nature =
eprintf "partition detection: %s is %s\n%!"
dev (string_of_nature nature);
- (part, nature)
+ (part, (size, nature))
) all_partitions
in
- printf "Finished detecting hard drives.\n%!";
+ print_endline (s_ "Finished detecting hard drives.");
(* Autodetect system memory. *)
let system_memory =
fun () ->
(* Greeting. *)
if !config_greeting then
- message_box program_name (sprintf "Welcome to %s, 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." program_name);
+ message_box program_name (sprintf (f_ "Welcome to %s, 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.") program_name);
(* Type of transfer. *)
let config_transfer_type =
| Some t -> t
| None ->
let items = [
- "Physical to Virtual (P2V)", P2V;
- "Virtual to Virtual (V2V)", V2V;
+ s_ "Physical to Virtual (P2V)", P2V;
+ s_ "Virtual to Virtual (V2V)", V2V;
] in
- select_single ~stage:"Transfer type" 40
- "Transfer type"
+ select_single ~stage:(s_ "Transfer type") 40
+ (s_ "Transfer type")
items in
(* Network configuration. *)
match !config_network with
| Some n -> n
| None ->
- open_centered_window ~stage:"Network"
- 60 20 "Configure network";
+ open_centered_window ~stage:(s_ "Network")
+ 60 20 (s_ "Configure network");
let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
Newt.listbox_set_width autolist 52;
*)
let rec loop = function
| [] -> ()
- | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
+ | (partition, (_, LinuxRoot (_, ((RHEL _|Fedora _) as distro))))
:: parts ->
let label =
sprintf "%s (%s)"
let auto =
Newt.radio_button 1 1
- "Automatic from:" (not no_auto) None in
+ (s_ "Automatic from:") (not no_auto) None in
let shell =
Newt.radio_button 1 6
- "Start a shell" no_auto (Some auto) in
+ (s_ "Start a shell") no_auto (Some auto) in
if no_auto then (
Newt.component_takes_focus auto false;
let qemu =
Newt.radio_button 1 7
- "QEMU user network" false (Some shell) in
+ (s_ "QEMU user network") false (Some shell) in
let nonet =
Newt.radio_button 1 8
- "No network or network already configured" false
- (Some qemu) in
+ (s_ "Don't configure the network") false (Some qemu) in
let static =
Newt.radio_button 1 9
- "Static configuration:" false (Some nonet) in
+ (s_ "Static configuration:") false (Some nonet) in
- let label1 = Newt.label 4 10 "Interface" in
+ let label1 = Newt.label 4 10 (s_ "Interface") in
let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
- let label2 = Newt.label 4 11 "Address" in
+ let label2 = Newt.label 4 11 (s_ "IP") in
let entry2 = Newt.entry 16 11 None 16 [] in
- let label3 = Newt.label 4 12 "Netmask" in
+ let label3 = Newt.label 4 12 (s_ "Netmask") in
let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
- let label4 = Newt.label 4 13 "Gateway" in
+ let label4 = Newt.label 4 13 (s_ "Gateway") in
let entry4 = Newt.entry 16 13 None 16 [] in
- let label5 = Newt.label 4 14 "Nameserver" in
+ let label5 = Newt.label 4 14 (s_ "Nameserver") in
let entry5 = Newt.entry 16 14 None 16 [] in
let enable_static () =
Newt.component_add_callback static
(fun () -> enable_static (); disable_autolist ());
- let ok = Newt.button 48 16 " OK " in
+ let ok = Newt.button 48 16 ok_button in
let form = Newt.form None None [] in
Newt.form_add_components form [auto;
(* Try to bring up the network. *)
(match config_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%!";
+ print_endline (s_ "Network configuration.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
shell ()
| Static (interface, address, netmask, gateway, nameserver) ->
- printf "Trying static network configuration.\n\n%!";
+ print_endline (s_ "Trying static network configuration.\n");
if not (static_network
(interface, address, netmask, gateway, nameserver)) 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";
+ print_endline (s_ "\nAuto-configuration failed. Starting a shell.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
shell ()
)
| Auto rootfs ->
- printf
- "Trying network auto-configuration from root filesystem ...\n\n%!";
+ print_endline
+ (s_ "Trying network auto-configuration from root filesystem ...\n");
(* Mount the root filesystem read-only under /mnt/root. *)
sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
if not (auto_network ()) 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";
+ print_endline (s_ "\nAuto-configuration failed. Starting a shell.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
shell ()
);
sh ("umount -l /mnt/root");
| QEMUUserNet ->
- printf "Trying QEMU network configuration.\n\n%!";
+ print_endline (s_ "Trying QEMU network configuration.\n");
qemu_network ()
| NoNetwork -> (* this is easy ... *) ()
| Some c -> c
| None ->
(* Query the user for SSH configuration. *)
- open_centered_window ~stage:"SSH configuration"
- 60 20 "SSH configuration";
+ open_centered_window ~stage:(s_ "SSH configuration")
+ 60 20 (s_ "SSH configuration");
- let label1 = Newt.label 1 1 "Remote host" in
+ let label1 = Newt.label 1 1 (s_ "Remote host") in
let host = Newt.entry 20 1 None 36 [] in
- let label2 = Newt.label 1 2 "Remote port" in
+ let label2 = Newt.label 1 2 (s_ "Remote port") in
let port = Newt.entry 20 2 (Some "22") 6 [] in
- let label3 = Newt.label 1 3 "Remote directory" in
+ let label3 = Newt.label 1 3 (s_ "Remote directory") in
let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
- let label4 = Newt.label 1 4 "SSH username" in
+ let label4 = Newt.label 1 4 (s_ "SSH username") in
let user = Newt.entry 20 4 (Some "root") 16 [] in
(*
There's no sensible way to support this for SSH:
- let label5 = Newt.label 1 5 "SSH password" in
+ let label5 = Newt.label 1 5 (s_ "SSH password") in
let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
*)
let compr =
- Newt.checkbox 16 7 "Use SSH compression (not good for LANs)"
+ Newt.checkbox 16 7 (s_ "Use SSH compression (not good for LANs)")
' ' None in
- let check = Newt.checkbox 16 9 "Test SSH connection" '*' None in
+ let check =
+ Newt.checkbox 16 9 (s_ "Test SSH connection") '*' None in
- let ok = Newt.button 48 16 " OK " in
+ let ok = Newt.button 48 16 ok_button in
let form = Newt.form None None [] in
Newt.form_add_components form [label1;label2;label3;label4;
(* If asked, check the SSH connection. *)
if config_ssh.ssh_check then
if not (test_ssh config_ssh) then
- failwith "SSH configuration failed";
+ failwith (s_ "SSH configuration failed");
(* Devices and root partition and target configuration selection stage. *)
let config_devices_to_send, config_root_filesystem, config_target =
let items = List.map (
fun (dev, size) ->
let label =
- sprintf "/dev/%s (%.3f GB)" dev
+ sprintf "%s (%.3f GB)" (dev_of_block_device 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"
+ select_multiple ~stage:(s_ "Block devices")
+ ~force_one:true 60
+ (s_ "Select block devices to send")
items in
let config_root_filesystem =
| Some fs -> fs
| None ->
let items = List.map (
- fun (part, nature) ->
+ 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"
+ select_single ~stage:(s_ "Root filesystem") 60
+ (s_ "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";
+ open_centered_window ~stage:(s_ "Target system") 40 20
+ (s_ "Configure target system");
- let hvlabel = Newt.label 1 1 "Hypervisor:" in
+ let hvlabel = Newt.label 1 1 (s_ "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 archlabel = Newt.label 1 5 (s_ "Architecture:") in
let archlistbox = Newt.listbox 16 5 4 [Newt.SCROLL] in
Newt.listbox_append_entry archlistbox "i386" I386;
Newt.listbox_append_entry archlistbox
Newt.listbox_set_current_by_key archlistbox UnknownArch;
(try
match List.assoc config_root_filesystem all_partitions with
- | LinuxRoot (arch, _) ->
+ | _, LinuxRoot (arch, _) ->
Newt.listbox_set_current_by_key archlistbox arch
| _ -> ()
with
Not_found -> ());
- let memlabel = Newt.label 1 9 "Memory (MB):" in
+ let memlabel = Newt.label 1 9 (s_ "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 cpulabel = Newt.label 1 10 (s_ "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 maclabel = Newt.label 1 11 (s_ "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 maclabel2 =
+ Newt.label 1 12 (s_ "(leave MAC blank for random)") in
let libvirtd =
- Newt.checkbox 12 14 "Use remote libvirtd" '*' None in
+ Newt.checkbox 12 14 (s_ "Use remote libvirtd") '*' None in
- let ok = Newt.button 28 16 " OK " in
+ let ok = Newt.button 28 16 ok_button in
let form = Newt.form None None [] in
Newt.form_add_components form
config_devices_to_send, config_root_filesystem, config_target
) in
+ (* If architecture is set to UnknownArch, then assume the same
+ * architecture as the live CD.
+ *)
+ let config_target =
+ match config_target.tgt_architecture with
+ | UnknownArch ->
+ let arch = shget "uname -m" in
+ let arch =
+ match arch with
+ | Some (arch :: _) -> architecture_of_string arch
+ | _ -> I386 (* probably wrong XXX *) in
+ { config_target with tgt_architecture = arch }
+ | _ -> config_target in
+
(* Try to get the capabilities from the remote machine. If we fail
* it doesn't matter too much.
*)
- let capabilities =
+ let caps_os_type, caps_emulator, caps_loader, caps_machine =
try
if not config_target.tgt_libvirtd then raise Not_found;
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;
+ eprintf "capabilities URI = %S\n%!" name;
+
+ print_endline (s_ "Try to fetch remote hypervisor capabilities ...\n");
let conn = Libvirt.Connect.connect_readonly ~name () in
let caps = Libvirt.Connect.get_capabilities conn in
Libvirt.Connect.close conn;
- eprintf "capabilities:\n%s\n%!" caps;
-
- Some caps
+ (* Turn it into XML data. *)
+ let caps = Xml.parse_string caps in
+ eprintf "capabilities:\n%s\n%!" (Xml.to_string_fmt caps);
+
+ (* We're looking for a guest with <os_type>hvm</os_type>
+ * and <arch name="target-arch">... Later when we can
+ * install PV drivers automatically, we will want to look
+ * for paravirt guest types too.
+ *)
+ let guests = children_with_name "guest" caps in
+ let guests =
+ List.filter (xml_has_pcdata_child "os_type" "hvm") guests in
+ let arch_str = string_of_architecture config_target.tgt_architecture in
+ let guests =
+ List.filter (
+ xml_has_child_matching (
+ function
+ | Xml.Element (n, attribs, _)
+ when n = "arch"
+ && List.exists (
+ fun (n, a) ->
+ n = "name" &&
+ (* deal with i386 vs i686 pestilence *)
+ architecture_of_string a = config_target.tgt_architecture
+ ) attribs
+ -> true
+ | _ -> false
+ )
+ ) guests in
+
+ (* In theory at this point we only have a single guest type
+ * remaining. It might be that we have _zero_ available
+ * guest types, which indicates probably an unsupported
+ * capability of the remote hypervisor (or just that one of
+ * many parsing or heuristics failed). It might be that
+ * we have > 1 available guest types, which indicates some
+ * feature we don't know about.
+ *)
+ let len = List.length guests in
+ if len = 0 then (
+ message_box (s_ "Warning")
+ (sprintf (f_ "Remote hypervisor claims not to support fully virtualized %s guests.\n\nContinuing anyway.\n\n%!") arch_str);
+ raise Not_found
+ );
+
+ if len > 1 then (
+ message_box (s_ "Note")
+ (sprintf (f_ "Remote hypervisor supports multiple types of fully virtualized %s guests.\n\nPlease help further development of libvirt and virt-p2v by sending the file /tmp/virt-p2v.log back to the developers. See the main virt-p2v website for contact details.") arch_str)
+ );
+
+ let guest = List.hd guests in
+
+ let os_type =
+ try Some (find_pcdata_child "os_type" guest)
+ with Not_found -> None in
+ let arch_section = find_child_with_name "arch" guest in
+ let emulator =
+ try Some (find_pcdata_child "emulator" arch_section)
+ with Not_found -> None in
+ let loader =
+ try Some (find_pcdata_child "loader" arch_section)
+ with Not_found -> None in
+ let machine =
+ try Some (find_pcdata_child "machine" arch_section)
+ with Not_found -> None in
+
+ os_type, emulator, loader, machine
with
- | Not_found -> None
+ | Not_found -> None, None, None, None
+ | Xml.Error err ->
+ eprintf "XML error: %s\n%!" (Xml.error err);
+ None, None, None, None
+ | Xml.Not_element _ | Xml.Not_pcdata _ | Xml.No_attribute _ ->
+ (* If these occur, need to add some more debugging. *)
+ eprintf "XML error when parsing capabilities\n%!";
+ None, None, None, None
| Libvirt.Virterror err ->
eprintf "libvirt error: %s\n%!" (Libvirt.Virterror.to_string err);
- None
+ None, None, None, None
| Invalid_argument str ->
eprintf "libvirt error: %s\n%!" str;
- None in
+ None, None, None, 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;
+ print_endline (s_ "Performing LVM snapshots ...\n");
+
(* Switch LVM config. *)
sh "vgchange -a n";
putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
(* Mount the root filesystem under /mnt/root. *)
(match config_root_filesystem with
- | Part (dev, partnum) ->
- let dev = dev ^ partnum in
+ | Part (dev, p) ->
let snapshot_dev = snapshot_name dev in
sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
- | LV (vg, lv) ->
+ | (LV _) as lv ->
(* The LV will be backed by a snapshot device, so just mount
* directly.
*)
- sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
+ let dev = dev_of_partition lv in
+ sh ("mount " ^ quote dev ^ " /mnt/root")
);
- (* Work out what devices will be called at the remote end. *)
- 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)
- ) config_devices_to_send in
+ (* Work out what devices will be called at the remote end and make
+ * a map of original device to remapped device name. This is
+ * quite simple for now: just map the devices to "hda", "hdb",
+ * etc. (assuming full virt target for now).
+ *)
+ let remote_map =
+ (* To generate "a", "b", ..., "aa", "ab", etc. The 'digits' are
+ * stored in reverse.
+ *)
+ let num = ref ['a'] in
+ let rec next_num_of num =
+ match num with
+ | [] -> assert false
+ | 'z' :: [] -> [ 'a'; 'a' ]
+ | 'z' :: nums -> 'a' :: next_num_of nums
+ | c :: nums -> Char.chr (Char.code c + 1) :: nums
+ in
+ let get_hdX num = "hd" ^ String.implode (List.rev num) in
+
+ List.map (
+ fun (origin_dev, _) ->
+ let remote_dev = get_hdX !num in
+ num := next_num_of !num;
+ (origin_dev, remote_dev)
+ ) config_devices_to_send in
(* Modify files on the root filesystem. *)
- rewrite_fstab config_devices_to_send;
+ rewrite_fstab remote_map;
(* XXX Other files to rewrite? *)
(* Unmount the root filesystem and sync disks. *)
sh "umount /mnt/root";
sh "sync"; (* Ugh, should be in stdlib. *)
- (* If architecture is set to UnknownArch, then assume the same
- * architecture as the live CD.
- *)
- let config_target =
- match config_target.tgt_architecture with
- | UnknownArch ->
- let arch = shget "uname -m" in
- let arch =
- match arch with
- | Some (("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.
*)
(* Work out what the image filenames will be at the remote end. *)
let config_devices_to_send = List.map (
- fun (origin_dev, snapshot_dev, remote_dev) ->
+ fun (origin_dev, snapshot_dev) ->
+ let remote_dev = List.assoc origin_dev remote_map in
let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
(origin_dev, snapshot_dev, remote_dev, remote_name)
) config_devices_to_send in
* 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.
(* ... and the _other_ sort of leaf (god I hate XML). *)
let tleaf name attribs = Xml.Element (name, attribs, []) in
+ let arch_str =
+ string_of_architecture config_target.tgt_architecture in
+ let arch_wordsize =
+ wordsize_of_architecture config_target.tgt_architecture in
+
(* Standard stuff for every domain. *)
let name = leaf "name" hostname in
let uuid = leaf "uuid" (random_uuid ()) in
let maxmem, memory =
- let m =
- leaf "maxmem" (string_of_int (config_target.tgt_memory * 1024)) in
- m, m in
+ let m = string_of_int (config_target.tgt_memory * 1024) in
+ leaf "maxmem" m, leaf "memory" 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 =
+ (* Use capabilities for os_type, etc. else use some good guesses. *)
+ let os_type = Option.default "hvm" caps_os_type in
+ let machine = Option.default "pc" caps_machine in
+ let loader = Option.default "/usr/lib/xen/boot/hvmloader" caps_loader in
+
match config_target.tgt_hypervisor with
| Some Xen ->
[Xml.Element ("os", [],
- [leaf "type" "hvm";
- leaf "loader" "/usr/lib/xen/boot/hvmloader";
+ [leaf "type" os_type;
+ leaf "loader" loader;
tleaf "boot" ["dev", "hd"]]);
Xml.Element ("features", [],
[tleaf "pae" [];
tleaf "apic" []]);
tleaf "clock" ["sync", "localtime"]]
| Some KVM ->
- [Xml.Element ("os", [], [leaf "type" "hvm"]);
+ [Xml.Element ("os", [], [leaf "type" os_type]);
tleaf "clock" ["sync", "localtime"]]
| Some QEMU ->
[Xml.Element ("os", [],
[Xml.Element ("type",
- ["arch",
- string_of_architecture
- config_target.tgt_architecture;
- "machine","pc"],
- [Xml.PCData "hvm"]);
+ ["arch", arch_str;
+ "machine", machine],
+ [Xml.PCData os_type]);
tleaf "boot" ["dev", "hd"]])]
| None ->
[] in
(* <devices> section. *)
let devices =
let emulator =
- match config_target.tgt_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"]
+ match caps_emulator with
+ (* Use the emulator from the libvirt capabilities. *)
+ | Some s -> [leaf "emulator" s]
| None ->
- [] in
+ (* If we don't have libvirt capabilities, best guess. *)
+ match config_target.tgt_hypervisor with
+ | Some Xen ->
+ [leaf "emulator"
+ (if arch_wordsize = W64 then "/usr/lib64/xen/bin/qemu-dm"
+ else "/usr/lib/xen/bin/qemu-dm")]
+ | 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",
match config_target.tgt_hypervisor with
| Some Xen | None -> ""
| Some QEMU | Some KVM -> " -c qemu:///system" in
- let xml = sprintf "\
+ let xml = sprintf (f_ "\
<!--
- This is a libvirt configuration file.
+ This is an automatically generated libvirt configuration file.
+ It was written by the %s program.
+
+ Please check the values in this configuration file carefully,
+ particularly maxmem, memory, vcpu and any paths.
To start the domain, do:
virsh%s define %s
virsh%s start %s
--->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
+-->\n\n") program_name conn_arg conf_filename conn_arg hostname
+ ^ xml
+ ^ "\n" in
let xml_len = String.length xml in
eprintf "length of configuration file is %d bytes\n%!" xml_len;
+ print_endline (s_ "\nWriting configuration file ...\n");
+
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);
*)
List.iter (
fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
- eprintf "sending %s as %s\n%!" origin_dev remote_name;
+ eprintf "sending %s as %s\n%!"
+ (dev_of_block_device 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.));
+ let () =
+ printf (f_ "\nSending /dev/%s (%.3f GB) to remote machine\n\n%!")
+ origin_dev ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
(* Open the snapshot device. *)
let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
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.)
+ printf (f_ " (about %.0f minutes remaining)")
+ (secs_remaining/.60.)
else
- printf " (about %.0f seconds remaining)"
+ printf (f_ " (about %.0f seconds remaining)")
secs_remaining
);
printf " \r%!";
(* Clean up and reboot. *)
ignore (
- 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."
+ message_box (sprintf (f_ "%s has finished") program_name)
+ (sprintf (f_ "\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.")
config_ssh.ssh_directory conf_filename)
);
(*----------------------------------------------------------------------*)
let usage () =
- eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
+ let () = eprintf (f_ "usage: virt-p2v [--test] [ttyname]\n%!") in
exit 2
(* Make sure that exceptions from 'main' get printed out on stdout
git.annexia.org / virt-p2v.git / blobdiff