1 #!/usr/bin/ocamlrun /usr/bin/ocaml
3 (* virt-p2v is a script which performs a physical to
4 * virtual conversion of local disks.
6 * Copyright (C) 2007-2008 Red Hat Inc.
7 * Written by Richard W.M. Jones <rjones@redhat.com>
9 * This program is free software; you can redistribute it and/or modify
10 * it under the terms of the GNU General Public License as published by
11 * the Free Software Foundation; either version 2 of the License, or
12 * (at your option) any later version.
14 * This program is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with this program; if not, write to the Free Software
21 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
25 #directory "+extlib";;
29 #directory "+xml-light";;
30 #load "xml-light.cma";;
37 type state = { greeting : bool;
38 remote_host : string option; remote_port : string option;
39 remote_directory : string option;
40 remote_username : string option;
41 network : network option;
42 devices_to_send : string list option;
43 root_filesystem : partition option;
44 hypervisor : hypervisor option;
45 architecture : architecture option;
46 memory : int option; vcpus : int option;
47 mac_address : string option;
49 and network = Auto | Shell
50 and partition = Part of string * string (* eg. "hda", "1" *)
51 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
52 and hypervisor = Xen | QEMU | KVM
53 and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
54 | OtherArch of string | UnknownArch
56 (*----------------------------------------------------------------------*)
57 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
59 * If left as they are, then this will create a generic virt-p2v script
60 * which asks the user for each question. If you set the defaults here
61 * then you will get a custom virt-p2v which is partially or even fully
62 * automated and won't ask the user any questions.
64 * Note that 'None' means 'no default' (ie. ask the user) whereas
65 * 'Some foo' means use 'foo' as the answer.
68 (* If greeting is true, wait for keypress after boot and during
69 * final verification. Set to 'false' for less interactions.
73 (* Remote host and port. Set to 'Some "host"' and 'Some "port"',
79 (* Remote directory. Set to 'Some "path"' to set up a
80 * directory path, else ask the user.
82 remote_directory = None;
84 (* Remote username for ssh. Set to 'Some "username"', or None to
87 remote_username = None;
89 (* List of devices to send. Set to 'Some ["sda"; "sdb"]' for
90 * example to select /dev/sda and /dev/sdb.
92 devices_to_send = None;
94 (* The root filesystem containing /etc/fstab. Set to
95 * 'Some (Part ("sda", "3"))' or 'Some (LV ("VolGroup00", "LogVol00"))'
96 * for example, else ask user.
98 root_filesystem = None;
100 (* Network configuration: Set to 'Some Auto' (try to set it up
101 * automatically, or 'Some Shell' (give the user a shell).
105 (* Hypervisor: Set to 'Some Xen', 'Some QEMU' or 'Some KVM'. *)
108 (* Architecture: Set to 'Some X86_64' (or another architecture).
109 * If set to 'Some UnknownArch' then we try to autodetect the
110 * right architecture.
114 (* Memory: Set to 'Some nn' with nn in megabytes. If set to 'Some 0'
115 * then we use same amount of RAM as installed in the physical machine.
119 (* Virtual CPUs: Set to 'Some nn' where nn is the number of virtual CPUs.
120 * If set to 'Some 0' then we use the same as physical CPUs in the
125 (* MAC address: Set to 'Some "aa:bb:cc:dd:ee:ff"' where the string is
126 * the MAC address of the emulated network card. Set to 'Some ""' to
127 * choose a random MAC address.
131 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
132 (*----------------------------------------------------------------------*)
134 (* General helper functions. *)
136 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
137 let xs = List.sort ~cmp xs in
138 let rec loop = function
139 | [] -> [] | [x] -> [x]
140 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
141 | x :: xs -> x :: loop xs
145 let input_all_lines chan =
146 let lines = ref [] in
148 while true do lines := input_line chan :: !lines done; []
150 End_of_file -> List.rev !lines
152 let dev_of_partition = function
153 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
154 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
156 let string_of_architecture = function
163 | SPARC64 -> "sparc64"
164 | OtherArch arch -> arch
167 type dialog_status = Yes of string list | No | Help | Back | Error
169 type ask_result = Next of state | Prev | Ask_again
171 type nature = LinuxSwap
172 | LinuxRoot of architecture * linux_distro
173 | WindowsRoot (* Windows C: *)
174 | LinuxBoot (* Linux /boot *)
175 | NotRoot (* mountable, but not / or /boot *)
177 and linux_distro = RHEL of int * int
179 | Debian of int * int
182 let rec string_of_nature = function
183 | LinuxSwap -> "Linux swap"
184 | LinuxRoot (architecture, distro) ->
185 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
186 | WindowsRoot -> "Windows root"
187 | LinuxBoot -> "Linux /boot"
188 | NotRoot -> "Mountable non-root"
189 | UnknownNature -> "Unknown"
190 and string_of_linux_distro = function
191 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
192 | Fedora v -> sprintf "Fedora %d" v
193 | Debian (a,b) -> sprintf "Debian %d.%d" a b
194 | OtherLinux -> "Linux"
198 * Each function takes some common parameters (eg. ~title) and some
199 * dialog-specific parameters.
201 * Returns the exit status (Yes lines | No | Help | Back | Error).
203 let msgbox, yesno, inputbox, radiolist, checklist =
204 (* Internal function to actually run the "dialog" shell command. *)
205 let run_dialog cparams params =
206 let params = cparams @ params in
207 eprintf "dialog %s\n%!"
208 (String.concat " " (List.map (sprintf "%S") params));
210 (* 'dialog' writes its output/result to stderr, so we need to take
211 * special steps to capture that - in other words, manual pipe/fork.
213 let rfd, wfd = pipe () in
215 | 0 -> (* child, runs dialog *)
217 dup2 wfd stderr; (* capture stderr to pipe *)
218 execvp "dialog" (Array.of_list ("dialog" :: params))
219 | pid -> (* parent *)
221 let chan = in_channel_of_descr rfd in
222 let result = input_all_lines chan in
224 eprintf "dialog result: %S\n%!" (String.concat "\n" result);
225 match snd (wait ()) with
226 | WEXITED 0 -> Yes result (* something selected / entered *)
227 | WEXITED 1 -> No (* cancel / no button *)
228 | WEXITED 2 -> Help (* help pressed *)
229 | WEXITED 3 -> Back (* back button *)
230 | WEXITED _ -> Error (* error or Esc *)
231 | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
232 | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
235 (* Handle the common parameters. Note Continuation Passing Style. *)
236 let with_common cont ?(cancel=false) ?(backbutton=true) title =
237 let params = ["--title"; title] in
238 let params = if not cancel then "--nocancel" :: params else params in
240 if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
245 (* Message box and yes/no box. *)
248 fun cparams text height width ->
250 [ "--msgbox"; text; string_of_int height; string_of_int width ]
254 fun cparams text height width ->
256 [ "--yesno"; text; string_of_int height; string_of_int width ]
259 (* Simple input box. *)
262 fun cparams text height width default ->
264 [ "--inputbox"; text; string_of_int height; string_of_int width;
268 (* Radio list and check list. *)
271 fun cparams text height width listheight items ->
272 let items = List.map (
274 | tag, item, true -> [ tag; item; "on" ]
275 | tag, item, false -> [ tag; item; "off" ]
277 let items = List.concat items in
278 let items = "--single-quoted" ::
279 "--radiolist" :: text ::
280 string_of_int height :: string_of_int width ::
281 string_of_int listheight :: items in
282 run_dialog cparams items
286 fun cparams text height width listheight items ->
287 let items = List.map (
289 | tag, item, true -> [ tag; item; "on" ]
290 | tag, item, false -> [ tag; item; "off" ]
292 let items = List.concat items in
293 let items = "--separate-output" ::
294 "--checklist" :: text ::
295 string_of_int height :: string_of_int width ::
296 string_of_int listheight :: items in
297 run_dialog cparams items
300 msgbox, yesno, inputbox, radiolist, checklist
302 (* Print failure dialog and exit. *)
303 let fail_dialog text =
304 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
305 ignore (msgbox "Error" text 17 50);
308 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
309 let quote = Filename.quote
311 (* Run a shell command and check it returns 0. *)
313 eprintf "sh: %s\n%!" cmd;
314 if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
317 eprintf "shfailok: %s\n%!" cmd;
318 ignore (Sys.command cmd)
320 let shwithstatus cmd =
321 eprintf "shwithstatus: %s\n%!" cmd;
324 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
326 eprintf "shget: %s\n%!" cmd;
327 let chan = open_process_in cmd in
328 let lines = input_all_lines chan in
329 match close_process_in chan with
330 | WEXITED 0 -> Some lines (* command succeeded *)
331 | WEXITED _ -> None (* command failed *)
332 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
333 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
335 (* Start an interactive shell. Need to juggle file descriptors a bit
336 * because bash write PS1 to stderr (currently directed to the logfile).
340 | 0 -> (* child, runs bash *)
343 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
345 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
347 | _ -> (* parent, waits *)
348 eprintf "waiting for subshell to exit\n%!";
351 (* Some true if is dir/file, Some false if not, None if not found. *)
353 try Some ((stat path).st_kind = S_DIR)
354 with Unix_error (ENOENT, "stat", _) -> None
356 try Some ((stat path).st_kind = S_REG)
357 with Unix_error (ENOENT, "stat", _) -> None
359 (* Useful regular expression. *)
360 let whitespace = Pcre.regexp "[ \t]+"
362 (* Generate a predictable safe name containing only letters, numbers
363 * and underscores. If passed a string with no letters or numbers,
364 * generates "_1", "_2", etc.
369 fun () -> incr i; "_" ^ string_of_int !i
372 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
373 let name = String.copy name in
374 let have_safe = ref false in
375 for i = 0 to String.length name - 1 do
376 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
378 if !have_safe then name else next_anon ()
380 type block_device = string * int64 (* "hda" & size in bytes *)
382 (* Parse the output of 'lvs' to get list of LV names, sizes,
383 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
386 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
390 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
394 let lines = List.map (Pcre.split ~rex:whitespace) lines in
397 | [vg; lv; pvs; lvsize]
398 | [_; vg; lv; pvs; lvsize] ->
399 let pvs = String.nsplit pvs "," in
400 let pvs = List.filter_map (
403 let subs = Pcre.exec ~rex:devname pv in
404 Some (Pcre.get_substring subs 1)
407 eprintf "lvs: unexpected device name: %s\n%!" pv;
410 LV (vg, lv), pvs, lvsize
412 failwith ("lvs: unexpected output: " ^ String.concat "," line)
415 (* Get the partitions on a block device.
416 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
418 let get_partitions dev =
419 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
420 let devdir = "/sys/block/" ^ dev in
421 let parts = Sys.readdir devdir in
422 let parts = Array.to_list parts in
423 let parts = List.filter (
424 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
426 let parts = List.filter_map (
429 let subs = Pcre.exec ~rex part in
430 Some (Part (dev, Pcre.get_substring subs 1))
436 (* Generate snapshot device name from device name. *)
437 let snapshot_name dev =
438 "snap" ^ (safe_name dev)
440 (* Perform a device-mapper snapshot with ramdisk overlay. *)
442 let next_free_ram_disk =
444 fun () -> incr i; "/dev/ram" ^ string_of_int !i
446 fun origin_dev snapshot_dev ->
447 let ramdisk = next_free_ram_disk () in
449 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
450 let lines = shget cmd in
452 | Some (sectors::_) -> Int64.of_string sectors
454 fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
456 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
457 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
458 snapshot_dev sectors origin_dev);
459 (* Create the snapshot. *)
460 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
461 snapshot_dev sectors snapshot_dev ramdisk)
463 (* Try to perform automatic network configuration, assuming a Fedora or
464 * RHEL-like root filesystem mounted on /mnt/root.
466 let auto_network state =
467 (* Fedora gives an error if this file doesn't exist. *)
468 sh "touch /etc/resolv.conf";
471 (* We can run /mnt/root/etc/init.d/network in a chroot environment,
472 * however this won't work directly because the architecture of the
473 * binaries under /mnt/root (eg. /mnt/root/sbin/ip) might not match
474 * the architecture of the live CD kernel. In particular, a 32 bit
475 * live CD cannot run 64 bit binaries. So we also have to bind-mount
476 * the live CD's /bin, /sbin, /lib etc. over the equivalents in
480 if is_dir dir = Some true then
481 sh ("mount -o bind " ^ quote dir ^ " " ^ quote ("/mnt/root" ^ dir))
484 if is_dir dir = Some true then sh ("umount -l " ^ quote ("/mnt/root" ^ dir))
487 "/bin"; "/sbin"; "/lib"; "/lib64";
488 "/usr/bin"; "/usr/sbin"; "/usr/lib"; "/usr/lib64";
492 let status = shwithstatus "chroot /mnt/root /etc/init.d/network start" in
493 List.iter unbind dirs;
496 (* Simpler way to do the above.
497 * NB. Lazy unmount is required because dhclient keeps its current
498 * directory open on /etc/sysconfig/network-scripts/
500 sh "mount -o bind /mnt/root/etc /etc";
501 let status = shwithstatus "/etc/init.d/network start" in
504 (* Try to ping the remote host to see if this worked. *)
505 shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
507 if state.greeting then (
508 printf "\n\nDid automatic network configuration work?\n";
509 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
511 let line = read_line () in
512 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
515 (* Non-interactive: return the status of /etc/init.d/network start. *)
518 (* Map local device names to remote devices names. At the moment we
519 * just change sd* to hd* (as device names appear under fullvirt). In
520 * future, lots of complex possibilities.
522 let remote_of_origin_dev =
523 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
524 let devsd_subst = Pcre.subst "hd$1" in
526 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
528 (* Rewrite /mnt/root/etc/fstab. *)
529 let rewrite_fstab state devices_to_send =
530 let filename = "/mnt/root/etc/fstab" in
531 if is_file filename = Some true then (
532 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
534 let chan = open_in filename in
535 let lines = input_all_lines chan in
537 let lines = List.map (Pcre.split ~rex:whitespace) lines in
538 let lines = List.map (
540 | dev :: rest when String.starts_with dev "/dev/" ->
541 let dev = String.sub dev 5 (String.length dev - 5) in
542 let dev = remote_of_origin_dev dev in
543 let dev = "/dev/" ^ dev in
548 let chan = open_out filename in
551 | [dev; mountpoint; fstype; options; freq; passno] ->
552 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
553 dev mountpoint fstype options freq passno
555 output_string chan (String.concat " " line)
560 (* Main entry point. *)
561 let rec main ttyname =
562 (* Running from an init script. We don't have much of a
563 * login environment, so set one up.
567 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
568 "/usr/bin"; "/bin"]);
569 putenv "HOME" "/root";
570 putenv "LOGNAME" "root";
572 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
575 (* Set up logging to /tmp/virt-p2v.log. *)
576 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
580 (* Log the start up time. *)
581 eprintf "\n\n**************************************************\n\n";
582 let tm = localtime (time ()) in
583 eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
584 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
586 (* Connect stdin/stdout to the tty. *)
590 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
594 printf "virt-p2v starting up ...\n%!";
596 (* Disable screen blanking on tty. *)
597 sh "setterm -blank 0";
599 (* Check that the environment is a sane-looking live CD. If not, bail. *)
600 if is_dir "/mnt/root" <> Some true then
602 "You should only run this script from the live CD or a USB key.";
604 printf "virt-p2v detecting hard drives (this may take some time) ...\n%!";
606 (* Search for all non-removable block devices. Do this early and bail
607 * if we can't find anything. This is a list of strings, like "hda".
609 let all_block_devices : block_device list =
610 let rex = Pcre.regexp "^[hs]d" in
611 let devices = Array.to_list (Sys.readdir "/sys/block") in
612 let devices = List.sort devices in
613 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
614 eprintf "all_block_devices: block devices: %s\n%!"
615 (String.concat "; " devices);
616 (* Run blockdev --getsize64 on each, and reject any where this fails
617 * (probably removable devices).
619 let devices = List.filter_map (
621 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
622 let lines = shget cmd in
624 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
625 | Some [] | None -> None
627 eprintf "all_block_devices: non-removable block devices: %s\n%!"
629 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
631 fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
634 (* Search for partitions and LVs (anything that could contain a
635 * filesystem directly). We refer to these generically as
638 let all_partitions : partition list =
641 let lvs = get_lvs () in
642 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
643 let pvs = List.concat pvs in
644 let pvs = sort_uniq pvs in
645 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
646 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
647 eprintf "all_partitions: LVs: %s\n%!"
648 (String.concat "; " (List.map dev_of_partition lvs));
651 (* Partitions (eg. "sda1", "sda2"). *)
653 let parts = List.map fst all_block_devices in
654 let parts = List.map get_partitions parts in
655 let parts = List.concat parts in
656 eprintf "all_partitions: all partitions: %s\n%!"
657 (String.concat "; " (List.map dev_of_partition parts));
659 (* Remove any partitions which are PVs. *)
660 let parts = List.filter (
662 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
663 | LV _ -> assert false
666 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
667 (String.concat "; " (List.map dev_of_partition parts));
669 (* Concatenate LVs & Parts *)
672 (* Try to determine the nature of each partition.
673 * Root? Swap? Architecture? etc.
675 let all_partitions : (partition * nature) list =
676 (* Output of 'file' command for Linux swap file. *)
677 let swap = Pcre.regexp "Linux.*swap.*file" in
678 (* Contents of /etc/redhat-release. *)
679 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
680 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
681 (* Contents of /etc/debian_version. *)
682 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
683 (* Output of 'file' on certain executables. *)
684 let i386 = Pcre.regexp ", Intel 80386," in
685 let x86_64 = Pcre.regexp ", x86-64," in
686 let itanic = Pcre.regexp ", IA-64," in
688 (* Examine the filesystem mounted on 'mnt' to determine the
689 * operating system, and, if Linux, the distro.
692 if is_dir (mnt ^ "/Windows") = Some true &&
693 is_file (mnt ^ "/autoexec.bat") = Some true then
695 else if is_dir (mnt ^ "/etc") = Some true &&
696 is_dir (mnt ^ "/sbin") = Some true &&
697 is_dir (mnt ^ "/var") = Some true then (
698 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
699 let chan = open_in (mnt ^ "/etc/redhat-release") in
700 let lines = input_all_lines chan in
704 | [] -> (* empty /etc/redhat-release ...? *)
705 LinuxRoot (UnknownArch, OtherLinux)
706 | line::_ -> (* try to detect OS from /etc/redhat-release *)
708 let subs = Pcre.exec ~rex:rhel line in
709 let major = int_of_string (Pcre.get_substring subs 1) in
711 try int_of_string (Pcre.get_substring subs 2)
712 with Not_found -> 0 in
713 LinuxRoot (UnknownArch, RHEL (major, minor))
715 Not_found | Failure "int_of_string" ->
717 let subs = Pcre.exec ~rex:fedora line in
718 let version = int_of_string (Pcre.get_substring subs 1) in
719 LinuxRoot (UnknownArch, Fedora version)
721 Not_found | Failure "int_of_string" ->
722 LinuxRoot (UnknownArch, OtherLinux)
724 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
725 let chan = open_in (mnt ^ "/etc/debian_version") in
726 let lines = input_all_lines chan in
730 | [] -> (* empty /etc/debian_version ...? *)
731 LinuxRoot (UnknownArch, OtherLinux)
732 | line::_ -> (* try to detect version from /etc/debian_version *)
734 let subs = Pcre.exec ~rex:debian line in
735 let major = int_of_string (Pcre.get_substring subs 1) in
736 let minor = int_of_string (Pcre.get_substring subs 2) in
737 LinuxRoot (UnknownArch, Debian (major, minor))
739 Not_found | Failure "int_of_string" ->
740 LinuxRoot (UnknownArch, OtherLinux)
743 LinuxRoot (UnknownArch, OtherLinux)
744 ) else if is_dir (mnt ^ "/grub") = Some true &&
745 is_file (mnt ^ "/grub/stage1") = Some true then (
748 NotRoot (* mountable, but not a root filesystem *)
751 (* Examine the Linux root filesystem mounted on 'mnt' to
752 * determine the architecture. We do this by looking at some
753 * well-known binaries that we expect to be there.
755 let detect_architecture mnt =
756 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
758 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
759 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
760 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
766 let dev = dev_of_partition part in (* Get /dev device. *)
769 (* Use 'file' command to detect if it is swap. *)
770 let cmd = "file -sbL " ^ quote dev in
772 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
774 (* Blindly try to mount the device. *)
775 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
776 match shwithstatus cmd with
778 let os = detect_os "/mnt/root" in
781 | LinuxRoot (UnknownArch, distro) ->
782 let architecture = detect_architecture "/mnt/root" in
783 LinuxRoot (architecture, distro)
785 sh "umount /mnt/root";
788 | _ -> UnknownNature (* not mountable *)
792 eprintf "partition detection: %s is %s\n%!"
793 dev (string_of_nature nature);
799 printf "virt-p2v finished detecting hard drives\n%!";
802 let ask_greeting state =
803 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);
807 let ask_hostname state =
809 inputbox "Remote host" "Remote host" 10 50
810 (Option.default "" state.remote_host)
812 | Yes [] -> Ask_again
813 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
814 | No | Help | Error -> Ask_again
820 inputbox "Remote port" "Remote port" 10 50
821 (Option.default "22" state.remote_port)
823 | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
824 | Yes (port::_) -> Next { state with remote_port = Some port }
825 | No | Help | Error -> Ask_again
829 let ask_directory state =
830 let default_dir = "/var/lib/xen/images" in
832 inputbox "Remote directory" "Remote directory" 10 50
833 (Option.default default_dir state.remote_directory)
835 | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
836 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
837 | No | Help | Error -> Ask_again
841 let ask_username state =
842 let default_username = "root" in
844 inputbox "Remote username" "Remote username for ssh access to server" 10 50
845 (Option.default default_username state.remote_username)
848 Next { state with remote_username = Some default_username }
849 | Yes (user::_) -> Next { state with remote_username = Some user }
850 | No | Help | Error -> Ask_again
854 let ask_network state =
856 radiolist "Network configuration" "Network configuration" 10 50 2 [
857 "auto", "Automatic configuration", state.network = Some Auto;
858 "sh", "Configure from the shell", state.network = Some Shell;
861 | Yes ("auto"::_) -> Next { state with network = Some Auto }
862 | Yes ("sh"::_) -> Next { state with network = Some Shell }
863 | Yes _ | No | Help | Error -> Ask_again
867 let ask_devices state =
868 let selected_devices = Option.default [] state.devices_to_send in
869 let devices = List.map (
870 fun (dev, blksize) ->
872 sprintf "/dev/%s (%.3f GB)" dev
873 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
874 List.mem dev selected_devices)
875 ) all_block_devices in
877 checklist "Devices" "Pick devices to send" 15 50 8 devices
879 | Yes [] | No | Help | Error -> Ask_again
880 | Yes devices -> Next { state with devices_to_send = Some devices }
885 let parts = List.mapi (
886 fun i (part, nature) ->
889 | LinuxSwap -> " (Linux swap)"
890 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
891 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
892 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
893 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
894 | WindowsRoot -> " (Windows C:)"
895 | LinuxBoot -> " (Linux /boot)"
896 | NotRoot -> " (filesystem)"
897 | UnknownNature -> "" in
899 dev_of_partition part ^ descr,
900 Some part = state.root_filesystem)
903 radiolist "Root device"
904 "Pick partition containing the root (/) filesystem" 18 70 9
908 let (part, _) = List.nth all_partitions (int_of_string i) in
909 Next { state with root_filesystem = Some part }
910 | Yes [] | No | Help | Error -> Ask_again
914 let ask_hypervisor state =
916 radiolist "Hypervisor"
917 "Choose hypervisor / virtualization system"
919 "xen", "Xen", state.hypervisor = Some Xen;
920 "qemu", "QEMU", state.hypervisor = Some QEMU;
921 "kvm", "KVM", state.hypervisor = Some KVM;
922 "other", "Other", state.hypervisor = None
925 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
926 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
927 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
928 | Yes _ -> Next { state with hypervisor = None }
929 | No | Help | Error -> Ask_again
933 let ask_architecture state =
935 radiolist "Architecture" "Machine architecture" 16 50 8 [
936 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
937 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
938 "ia64", "Itanium IA64", state.architecture = Some IA64;
939 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
940 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
941 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
942 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
943 "auto", "Auto-detect",
944 state.architecture = None || state.architecture = Some UnknownArch;
947 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
948 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
949 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
950 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
951 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
952 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
953 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
954 | Yes _ -> Next { state with architecture = Some UnknownArch }
955 | No | Help | Error -> Ask_again
959 let ask_memory state =
961 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
963 (Option.map_default string_of_int "" state.memory)
965 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
967 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
968 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
969 else Next { state with memory = Some mem }
970 | No | Help | Error -> Ask_again
974 let ask_vcpus state =
976 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
978 (Option.map_default string_of_int "" state.vcpus)
980 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
983 try int_of_string vcpus with Failure "int_of_string" -> -1 in
984 if vcpus < 0 then Ask_again
985 else Next { state with vcpus = Some vcpus }
986 | No | Help | Error -> Ask_again
990 let ask_mac_address state =
992 inputbox "MAC address"
993 "Network MAC address. Leave blank to use a random address." 10 50
994 (Option.default "" state.mac_address)
996 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
997 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
998 | No | Help | Error -> Ask_again
1002 let ask_verify state =
1004 yesno "Verify and proceed"
1005 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1017 (Option.default "" state.remote_host)
1018 (Option.default "" state.remote_port)
1019 (Option.default "" state.remote_directory)
1020 (match state.network with
1021 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1023 (String.concat "," (Option.default [] state.devices_to_send))
1024 (Option.map_default dev_of_partition "" state.root_filesystem)
1025 (match state.hypervisor with
1026 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1027 | None -> "Other / not set")
1028 (match state.architecture with
1029 | Some UnknownArch -> "Auto-detect"
1030 | Some arch -> string_of_architecture arch | None -> "")
1031 (match state.memory with
1032 | Some 0 -> "Same as physical"
1033 | Some mem -> string_of_int mem ^ " MB" | None -> "")
1034 (match state.vcpus with
1035 | Some 0 -> "Same as physical"
1036 | Some vcpus -> string_of_int vcpus | None -> "")
1037 (match state.mac_address with
1038 | Some "" -> "Random" | Some mac -> mac | None -> "")
1042 | Yes _ -> Next state
1044 | No | Help | Error -> Ask_again
1047 (* This is the list of dialogs, in order. The user can go forwards or
1048 * backwards through them. The second parameter in each pair is
1049 * false if we need to skip this dialog (info already supplied in
1050 * 'defaults' above).
1053 ask_greeting, (* Initial greeting. *)
1055 ask_hostname, (* Hostname. *)
1056 defaults.remote_host = None;
1057 ask_port, (* Port number. *)
1058 defaults.remote_port = None;
1059 ask_directory, (* Remote directory. *)
1060 defaults.remote_directory = None;
1061 ask_username, (* Remote username. *)
1062 defaults.remote_username = None;
1063 ask_network, (* Network configuration. *)
1064 defaults.network = None;
1065 ask_devices, (* Block devices to send. *)
1066 defaults.devices_to_send = None;
1067 ask_root, (* Root filesystem. *)
1068 defaults.root_filesystem = None;
1069 ask_hypervisor, (* Hypervisor. *)
1070 defaults.hypervisor = None;
1071 ask_architecture, (* Architecture. *)
1072 defaults.architecture = None;
1073 ask_memory, (* Memory. *)
1074 defaults.memory = None;
1075 ask_vcpus, (* VCPUs. *)
1076 defaults.vcpus = None;
1077 ask_mac_address, (* MAC address. *)
1078 defaults.mac_address = None;
1079 ask_verify, (* Verify settings. *)
1083 (* Loop through the dialogs until we reach the end. *)
1084 let rec loop posn state =
1085 eprintf "dialog loop: posn = %d\n%!" posn;
1086 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1088 let dlg, no_skip = dlgs.(posn) in
1089 let skip = not no_skip in
1091 (* Skip this dialog and move straight to the next one. *)
1095 match dlg state with
1096 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1097 | Prev -> loop (posn-1) state (* Backwards / back button. *)
1098 | Ask_again -> loop posn state (* Repeat the question. *)
1102 let state = loop 0 defaults in
1104 eprintf "finished dialog loop\n%!";
1106 (* Switch LVM config. *)
1108 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1109 sh "rm -f /etc/lvm/cache/.cache";
1110 sh "rm -f /etc/lvm.new/cache/.cache";
1112 (* Snapshot the block devices to send. *)
1113 let devices_to_send = Option.get state.devices_to_send in
1114 let devices_to_send =
1117 let snapshot_dev = snapshot_name origin_dev in
1118 snapshot origin_dev snapshot_dev;
1119 (origin_dev, snapshot_dev)
1120 ) devices_to_send in
1122 (* Run kpartx on the snapshots. *)
1124 fun (origin, snapshot) ->
1125 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1128 (* Rescan for LVs. *)
1132 (* Mount the root filesystem under /mnt/root. *)
1133 let root_filesystem = Option.get state.root_filesystem in
1134 (match root_filesystem with
1135 | Part (dev, partnum) ->
1136 let dev = dev ^ partnum in
1137 let snapshot_dev = snapshot_name dev in
1138 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1141 (* The LV will be backed by a snapshot device, so just mount
1144 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1147 (* See if we can do network configuration. *)
1148 let network = Option.get state.network in
1151 printf "Network configuration.\n\n";
1152 printf "Please configure the network from this shell.\n\n";
1153 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1158 "Trying network auto-configuration from root filesystem ...\n\n%!";
1159 if not (auto_network state) then (
1160 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1161 printf "Please configure the network from this shell.\n\n";
1162 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1167 (* Work out what devices will be called at the remote end. *)
1168 let devices_to_send = List.map (
1169 fun (origin_dev, snapshot_dev) ->
1170 let remote_dev = remote_of_origin_dev origin_dev in
1171 (origin_dev, snapshot_dev, remote_dev)
1172 ) devices_to_send in
1174 (* Modify files on the root filesystem. *)
1175 rewrite_fstab state devices_to_send;
1176 (* XXX Other files to rewrite? *)
1178 (* Unmount the root filesystem and sync disks. *)
1179 sh "umount /mnt/root";
1180 sh "sync"; (* Ugh, should be in stdlib. *)
1182 (* Get architecture of root filesystem, detected previously. *)
1183 let system_architecture =
1185 (match List.assoc root_filesystem all_partitions with
1186 | LinuxRoot (arch, _) -> arch
1187 | _ -> raise Not_found
1191 (* None was detected before, so assume same as live CD. *)
1192 let arch = shget "uname -m" in
1194 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1195 | Some ("x86_64"::_) -> X86_64
1196 | Some ("ia64"::_) -> IA64
1197 | _ -> I386 (* probably wrong XXX *) in
1199 (* Autodetect system memory. *)
1201 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
1203 | Some (mem::_) -> int_of_float (float_of_string mem)
1206 (* Autodetect system # pCPUs. *)
1207 let system_nr_cpus =
1209 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
1211 | Some (cpus::_) -> int_of_string cpus
1214 let remote_host = Option.get state.remote_host in
1215 let remote_port = Option.get state.remote_port in
1216 let remote_directory = Option.get state.remote_directory in
1217 let remote_username = Option.get state.remote_username in
1219 (* Functions to connect and disconnect from the remote system. *)
1220 let do_connect remote_name _ =
1221 let cmd = sprintf "ssh -C -l %s -p %s %s \"cat > %s/%s\""
1222 (quote remote_username) (quote remote_port) (quote remote_host)
1223 (quote remote_directory) (quote remote_name) in
1224 eprintf "connect: %s\n%!" cmd;
1225 let chan = open_process_out cmd in
1226 descr_of_out_channel chan, chan
1228 let do_disconnect (_, chan) =
1229 match close_process_out chan with
1230 | WEXITED 0 -> () (* OK *)
1231 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1232 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1233 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1236 (* XXX This is using the hostname derived from network configuration
1237 * above. We might want to ask the user to choose.
1239 let hostname = safe_name (gethostname ()) in
1241 let date = sprintf "%04d%02d%02d%02d%02d"
1242 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1243 "p2v-" ^ hostname ^ "-" ^ date in
1245 (* Work out what the image filenames will be at the remote end. *)
1246 let devices_to_send = List.map (
1247 fun (origin_dev, snapshot_dev, remote_dev) ->
1248 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1249 (origin_dev, snapshot_dev, remote_dev, remote_name)
1250 ) devices_to_send in
1252 (* Write a configuration file. Not sure if this is any better than
1253 * just 'sprintf-ing' bits of XML text together, but at least we will
1254 * always get well-formed XML.
1256 * XXX For some of the stuff here we really should do a
1257 * virConnectGetCapabilities call to the remote host first.
1259 * XXX There is a case for using virt-install to generate this XML.
1260 * When we start to incorporate libvirt access & storage API this
1261 * needs to be rethought.
1263 let conf_filename = basename ^ ".conf" in
1266 match state.architecture with
1267 | Some UnknownArch | None -> system_architecture
1268 | Some arch -> arch in
1270 match state.memory with
1271 | Some 0 | None -> system_memory
1272 | Some memory -> memory in
1274 match state.vcpus with
1275 | Some 0 | None -> system_nr_cpus
1278 match state.mac_address with
1281 List.map (sprintf "%02x") (
1282 List.map (fun _ -> Random.int 256) [0;0;0]
1284 String.concat ":" ("00"::"16"::"3e"::random)
1285 | Some mac -> mac in
1288 (* Shortcut to make "<name>value</name>". *)
1289 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1290 (* ... and the _other_ sort of leaf (god I hate XML). *)
1291 let tleaf name attribs = Xml.Element (name, attribs, []) in
1293 (* Standard stuff for every domain. *)
1294 let name = leaf "name" hostname in
1295 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1296 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1298 (* Top-level stuff which differs for each HV type (isn't this supposed
1299 * to be portable ...)
1302 match state.hypervisor with
1304 [Xml.Element ("os", [],
1306 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1307 tleaf "boot" ["dev", "hd"]]);
1308 Xml.Element ("features", [],
1312 tleaf "clock" ["sync", "localtime"]]
1314 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1315 tleaf "clock" ["sync", "localtime"]]
1317 [Xml.Element ("os", [],
1318 [Xml.Element ("type",
1320 string_of_architecture architecture;
1322 [Xml.PCData "hvm"]);
1323 tleaf "boot" ["dev", "hd"]])]
1327 (* <devices> section. *)
1330 match state.hypervisor with
1332 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1334 [leaf "emulator" "/usr/bin/qemu"]
1336 [leaf "emulator" "/usr/bin/qemu-kvm"]
1340 Xml.Element ("interface", ["type", "user"],
1341 [tleaf "mac" ["address", mac_address]]) in
1342 (* XXX should have an option for Xen bridging:
1344 "interface", ["type","bridge"],
1345 [tleaf "source" ["bridge","xenbr0"];
1346 tleaf "mac" ["address",mac_address];
1347 tleaf "script" ["path","vif-bridge"]])*)
1348 let graphics = tleaf "graphics" ["type", "vnc"] in
1350 let disks = List.map (
1351 fun (_, _, remote_dev, remote_name) ->
1353 "disk", ["type", "file";
1355 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1356 tleaf "target" ["dev", remote_dev]]
1358 ) devices_to_send in
1362 emulator @ interface :: graphics :: disks
1365 (* Put it all together in <domain type='foo'>. *)
1368 (match state.hypervisor with
1369 | Some Xen -> ["type", "xen"]
1370 | Some QEMU -> ["type", "qemu"]
1371 | Some KVM -> ["type", "kvm"]
1373 name :: memory :: vcpu :: extras @ [devices]
1376 (* Convert XML configuration file to a string, then send it to the
1380 let xml = Xml.to_string_fmt xml in
1383 match state.hypervisor with
1384 | Some Xen | None -> ""
1385 | Some QEMU | Some KVM -> " -c qemu:///system" in
1386 let xml = sprintf "\
1388 This is a libvirt configuration file.
1390 To start the domain, do:
1393 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1395 let xml_len = String.length xml in
1396 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1398 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1399 (* In OCaml this actually loops calling write(2) *)
1400 ignore (write sock xml 0 xml_len);
1401 do_disconnect conn in
1403 (* Send the device snapshots to the remote host. *)
1404 (* XXX This code should be made more robust against both network
1405 * errors and local I/O errors. Also should allow the user several
1406 * attempts to connect, or let them go back to the dialog stage.
1409 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1410 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1413 try List.assoc origin_dev all_block_devices
1414 with Not_found -> assert false (* internal error *) in
1416 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1417 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1419 (* Open the snapshot device. *)
1420 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1423 let (sock,_) as conn = do_connect remote_name size in
1425 (* Copy the data. *)
1426 let bufsize = 1024 * 1024 in
1427 let buffer = String.create bufsize in
1428 let start = gettimeofday () in
1430 let rec copy bytes_sent last_printed_at =
1431 let n = read fd buffer 0 bufsize in
1433 ignore (write sock buffer 0 n);
1435 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1436 let last_printed_at =
1437 let now = gettimeofday () in
1438 (* Print progress once per second. *)
1439 if now -. last_printed_at > 1. then (
1440 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1441 let secs_elapsed = now -. start in
1442 printf "%.0f%%" (100. *. elapsed);
1443 (* After 60 seconds has elapsed, start printing estimates. *)
1444 if secs_elapsed >= 60. then (
1445 let remaining = 1. -. elapsed in
1446 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1447 if secs_remaining > 120. then
1448 printf " (about %.0f minutes remaining) "
1449 (secs_remaining /. 60.)
1451 printf " (about %.0f seconds remaining) "
1457 else last_printed_at in
1459 copy bytes_sent last_printed_at
1468 (* Clean up and reboot. *)
1470 msgbox "virt-p2v completed"
1471 (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."
1472 remote_directory conf_filename)
1481 eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1484 (* Make sure that exceptions from 'main' get printed out on stdout
1485 * as well as stderr, since stderr is probably redirected to the
1486 * logfile, and so not visible to the user.
1488 let handle_exn f arg =
1490 with exn -> print_endline (Printexc.to_string exn); raise exn
1492 (* Test harness for the Makefile. The Makefile invokes this script as
1493 * 'virt-p2v --test' just to check it compiles. When it is running
1494 * from the actual live CD, there is a single parameter which is the
1495 * tty name (so usually 'virt-p2v tty1').
1498 match Array.to_list Sys.argv with
1499 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1500 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1501 | [ _; ttyname ] -> (* Run main with ttyname. *)
1502 handle_exn main (Some ttyname)
1503 | [ _ ] -> (* Interactive - no ttyname. *)
1504 handle_exn main None
1507 (* This file must end with a newline *)