1 #!/usr/bin/ocamlrun /usr/bin/ocaml
7 #directory "+xml-light";;
8 #load "xml-light.cma";;
10 (* virt-p2v.ml is a script which performs a physical to
11 * virtual conversion of local disks.
13 * Copyright (C) 2007-2008 Red Hat Inc.
14 * Written by Richard W.M. Jones <rjones@redhat.com>
16 * This program is free software; you can redistribute it and/or modify
17 * it under the terms of the GNU General Public License as published by
18 * the Free Software Foundation; either version 2 of the License, or
19 * (at your option) any later version.
21 * This program is distributed in the hope that it will be useful,
22 * but WITHOUT ANY WARRANTY; without even the implied warranty of
23 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 * GNU General Public License for more details.
26 * You should have received a copy of the GNU General Public License
27 * along with this program; if not, write to the Free Software
28 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
36 type state = { greeting : bool;
37 remote_host : string option; remote_port : string option;
38 remote_directory : string option;
39 network : network option;
40 devices_to_send : string list option;
41 root_filesystem : partition option;
42 hypervisor : hypervisor option;
43 architecture : architecture option;
44 memory : int option; vcpus : int option;
45 mac_address : string option;
47 and network = Auto | Shell
48 and partition = Part of string * string (* eg. "hda", "1" *)
49 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
50 and hypervisor = Xen | QEMU | KVM
51 and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
52 | OtherArch of string | UnknownArch
54 (*----------------------------------------------------------------------*)
55 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
57 * If left as they are, then this will create a generic virt-p2v script
58 * which asks the user for each question. If you set the defaults here
59 * then you will get a custom virt-p2v which is partially or even fully
60 * automated and won't ask the user any questions.
62 * Note that 'None' means 'no default' (ie. ask the user) whereas
63 * 'Some foo' means use 'foo' as the answer.
66 (* If greeting is true, wait for keypress after boot and during
67 * final verification. Set to 'false' for less interactions.
71 (* Remote host and port. Set to 'Some "host"' and 'Some "port"',
77 (* Remote directory. Set to 'Some "path"' to set up a
78 * directory path, else ask the user.
80 remote_directory = None;
82 (* List of devices to send. Set to 'Some ["sda"; "sdb"]' for
83 * example to select /dev/sda and /dev/sdb.
85 devices_to_send = None;
87 (* The root filesystem containing /etc/fstab. Set to
88 * 'Some (Part ("sda", "3"))' or 'Some (LV ("VolGroup00", "LogVol00"))'
89 * for example, else ask user.
91 root_filesystem = None;
93 (* Network configuration: Set to 'Some Auto' (try to set it up
94 * automatically, or 'Some Shell' (give the user a shell).
98 (* Hypervisor: Set to 'Some Xen', 'Some QEMU' or 'Some KVM'. *)
101 (* Architecture: Set to 'Some X86_64' (or another architecture).
102 * If set to 'Some UnknownArch' then we try to autodetect the
103 * right architecture.
107 (* Memory: Set to 'Some nn' with nn in megabytes. If set to 'Some 0'
108 * then we use same amount of RAM as installed in the physical machine.
112 (* Virtual CPUs: Set to 'Some nn' where nn is the number of virtual CPUs.
113 * If set to 'Some 0' then we use the same as physical CPUs in the
118 (* MAC address: Set to 'Some "aa:bb:cc:dd:ee:ff"' where the string is
119 * the MAC address of the emulated network card. Set to 'Some ""' to
120 * choose a random MAC address.
124 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
125 (*----------------------------------------------------------------------*)
127 (* General helper functions. *)
129 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
130 let xs = List.sort ~cmp xs in
131 let rec loop = function
132 | [] -> [] | [x] -> [x]
133 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
134 | x :: xs -> x :: loop xs
138 let input_all_lines chan =
139 let lines = ref [] in
141 while true do lines := input_line chan :: !lines done; []
143 End_of_file -> List.rev !lines
145 let dev_of_partition = function
146 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
147 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
149 let string_of_architecture = function
156 | SPARC64 -> "sparc64"
157 | OtherArch arch -> arch
160 type dialog_status = Yes of string list | No | Help | Back | Error
162 type ask_result = Next of state | Prev | Ask_again
164 type nature = LinuxSwap
165 | LinuxRoot of architecture * linux_distro
166 | WindowsRoot (* Windows C: *)
167 | LinuxBoot (* Linux /boot *)
168 | NotRoot (* mountable, but not / or /boot *)
170 and linux_distro = RHEL of int * int
172 | Debian of int * int
175 let rec string_of_nature = function
176 | LinuxSwap -> "Linux swap"
177 | LinuxRoot (architecture, distro) ->
178 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
179 | WindowsRoot -> "Windows root"
180 | LinuxBoot -> "Linux /boot"
181 | NotRoot -> "Mountable non-root"
182 | UnknownNature -> "Unknown"
183 and string_of_linux_distro = function
184 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
185 | Fedora v -> sprintf "Fedora %d" v
186 | Debian (a,b) -> sprintf "Debian %d.%d" a b
187 | OtherLinux -> "Linux"
191 * Each function takes some common parameters (eg. ~title) and some
192 * dialog-specific parameters.
194 * Returns the exit status (Yes lines | No | Help | Back | Error).
196 let msgbox, yesno, inputbox, radiolist, checklist =
197 (* Internal function to actually run the "dialog" shell command. *)
198 let run_dialog cparams params =
199 let params = cparams @ params in
200 eprintf "dialog %s\n%!"
201 (String.concat " " (List.map (sprintf "%S") params));
203 (* 'dialog' writes its output/result to stderr, so we need to take
204 * special steps to capture that - in other words, manual pipe/fork.
206 let rfd, wfd = pipe () in
208 | 0 -> (* child, runs dialog *)
210 dup2 wfd stderr; (* capture stderr to pipe *)
211 execvp "dialog" (Array.of_list ("dialog" :: params))
212 | pid -> (* parent *)
214 let chan = in_channel_of_descr rfd in
215 let result = input_all_lines chan in
217 eprintf "dialog result: %S\n%!" (String.concat "\n" result);
218 match snd (wait ()) with
219 | WEXITED 0 -> Yes result (* something selected / entered *)
220 | WEXITED 1 -> No (* cancel / no button *)
221 | WEXITED 2 -> Help (* help pressed *)
222 | WEXITED 3 -> Back (* back button *)
223 | WEXITED _ -> Error (* error or Esc *)
224 | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
225 | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
228 (* Handle the common parameters. Note Continuation Passing Style. *)
229 let with_common cont ?(cancel=false) ?(backbutton=true) title =
230 let params = ["--title"; title] in
231 let params = if not cancel then "--nocancel" :: params else params in
233 if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
238 (* Message box and yes/no box. *)
241 fun cparams text height width ->
243 [ "--msgbox"; text; string_of_int height; string_of_int width ]
247 fun cparams text height width ->
249 [ "--yesno"; text; string_of_int height; string_of_int width ]
252 (* Simple input box. *)
255 fun cparams text height width default ->
257 [ "--inputbox"; text; string_of_int height; string_of_int width;
261 (* Radio list and check list. *)
264 fun cparams text height width listheight items ->
265 let items = List.map (
267 | tag, item, true -> [ tag; item; "on" ]
268 | tag, item, false -> [ tag; item; "off" ]
270 let items = List.concat items in
271 let items = "--single-quoted" ::
272 "--radiolist" :: text ::
273 string_of_int height :: string_of_int width ::
274 string_of_int listheight :: items in
275 run_dialog cparams items
279 fun cparams text height width listheight items ->
280 let items = List.map (
282 | tag, item, true -> [ tag; item; "on" ]
283 | tag, item, false -> [ tag; item; "off" ]
285 let items = List.concat items in
286 let items = "--separate-output" ::
287 "--checklist" :: text ::
288 string_of_int height :: string_of_int width ::
289 string_of_int listheight :: items in
290 run_dialog cparams items
293 msgbox, yesno, inputbox, radiolist, checklist
295 (* Print failure dialog and exit. *)
296 let fail_dialog text =
297 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
298 ignore (msgbox "Error" text 17 50);
301 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
302 let quote = Filename.quote
304 (* Run a shell command and check it returns 0. *)
306 eprintf "sh: %s\n%!" cmd;
307 if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
310 eprintf "shfailok: %s\n%!" cmd;
311 ignore (Sys.command cmd)
313 let shwithstatus cmd =
314 eprintf "shwithstatus: %s\n%!" cmd;
317 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
319 eprintf "shget: %s\n%!" cmd;
320 let chan = open_process_in cmd in
321 let lines = input_all_lines chan in
322 match close_process_in chan with
323 | WEXITED 0 -> Some lines (* command succeeded *)
324 | WEXITED _ -> None (* command failed *)
325 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
326 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
328 (* Start an interactive shell. Need to juggle file descriptors a bit
329 * because bash write PS1 to stderr (currently directed to the logfile).
333 | 0 -> (* child, runs bash *)
336 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
338 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
340 | _ -> (* parent, waits *)
341 eprintf "waiting for subshell to exit\n%!";
344 (* Some true if is dir/file, Some false if not, None if not found. *)
346 try Some ((stat path).st_kind = S_DIR)
347 with Unix_error (ENOENT, "stat", _) -> None
349 try Some ((stat path).st_kind = S_REG)
350 with Unix_error (ENOENT, "stat", _) -> None
352 (* Useful regular expression. *)
353 let whitespace = Pcre.regexp "[ \t]+"
355 (* Generate a predictable safe name containing only letters, numbers
356 * and underscores. If passed a string with no letters or numbers,
357 * generates "_1", "_2", etc.
362 fun () -> incr i; "_" ^ string_of_int !i
365 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
366 let name = String.copy name in
367 let have_safe = ref false in
368 for i = 0 to String.length name - 1 do
369 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
371 if !have_safe then name else next_anon ()
373 type block_device = string * int64 (* "hda" & size in bytes *)
375 (* Parse the output of 'lvs' to get list of LV names, sizes,
376 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
379 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
383 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
387 let lines = List.map (Pcre.split ~rex:whitespace) lines in
390 | [vg; lv; pvs; lvsize]
391 | [_; vg; lv; pvs; lvsize] ->
392 let pvs = String.nsplit pvs "," in
393 let pvs = List.filter_map (
396 let subs = Pcre.exec ~rex:devname pv in
397 Some (Pcre.get_substring subs 1)
400 eprintf "lvs: unexpected device name: %s\n%!" pv;
403 LV (vg, lv), pvs, lvsize
405 failwith ("lvs: unexpected output: " ^ String.concat "," line)
408 (* Get the partitions on a block device.
409 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
411 let get_partitions dev =
412 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
413 let devdir = "/sys/block/" ^ dev in
414 let parts = Sys.readdir devdir in
415 let parts = Array.to_list parts in
416 let parts = List.filter (
417 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
419 let parts = List.filter_map (
422 let subs = Pcre.exec ~rex part in
423 Some (Part (dev, Pcre.get_substring subs 1))
429 (* Generate snapshot device name from device name. *)
430 let snapshot_name dev =
431 "snap" ^ (safe_name dev)
433 (* Perform a device-mapper snapshot with ramdisk overlay. *)
435 let next_free_ram_disk =
437 fun () -> incr i; "/dev/ram" ^ string_of_int !i
439 fun origin_dev snapshot_dev ->
440 let ramdisk = next_free_ram_disk () in
442 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
443 let lines = shget cmd in
445 | Some (sectors::_) -> Int64.of_string sectors
447 fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
449 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
450 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
451 snapshot_dev sectors origin_dev);
452 (* Create the snapshot. *)
453 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
454 snapshot_dev sectors snapshot_dev ramdisk)
456 (* Try to perform automatic network configuration, assuming a Fedora or
457 * RHEL-like root filesystem mounted on /mnt/root.
459 let auto_network state =
460 (* Fedora gives an error if this file doesn't exist. *)
461 sh "touch /etc/resolv.conf";
463 (* It's tempting to do a 'chroot ...' and run the original
464 * '/etc/init.d/network start' script. However this will not
465 * always work, in particular in the case where the root is
466 * a 64 bit machine and the live CD kernel is 32 bit, and so
467 * cannot run binaries such as /sbin/ifconfig from the root.
468 * Do it the hard way instead ...
470 chdir "/etc/sysconfig";
471 sh "mv network network.saved";
472 sh "mv networking networking.saved";
473 sh "mv network-scripts network-scripts.saved";
475 sh "mv network network.saved";
476 sh "mv functions functions.saved";
478 (* Originally I symlinked these, but that causes dhclient to
479 * keep open /mnt/root (as its cwd is in network-scripts subdir).
480 * So now we will copy them recursively instead.
482 chdir "/etc/sysconfig";
483 sh "cp -a /mnt/root/etc/sysconfig/network .";
484 sh "cp -a /mnt/root/etc/sysconfig/networking .";
485 sh "cp -a /mnt/root/etc/sysconfig/network-scripts .";
487 sh "cp /mnt/root/etc/init.d/network .";
488 sh "cp /mnt/root/etc/init.d/functions .";
490 let status = shwithstatus "/etc/init.d/network start" in
492 chdir "/etc/sysconfig";
493 sh "rm -rf network networking network-scripts";
494 sh "mv network.saved network";
495 sh "mv networking.saved networking";
496 sh "mv network-scripts.saved network-scripts";
498 sh "rm -f network functions";
499 sh "mv network.saved network";
500 sh "mv functions.saved functions";
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.ml starting up ...\n%!";
596 (* Check that the environment is a sane-looking live CD. If not, bail. *)
597 if is_dir "/mnt/root" <> Some true then
599 "You should only run this script from the live CD or a USB key.";
601 printf "virt-p2v.ml detecting hard drives (this may take some time) ...\n%!";
603 (* Search for all non-removable block devices. Do this early and bail
604 * if we can't find anything. This is a list of strings, like "hda".
606 let all_block_devices : block_device list =
607 let rex = Pcre.regexp "^[hs]d" in
608 let devices = Array.to_list (Sys.readdir "/sys/block") in
609 let devices = List.sort devices in
610 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
611 eprintf "all_block_devices: block devices: %s\n%!"
612 (String.concat "; " devices);
613 (* Run blockdev --getsize64 on each, and reject any where this fails
614 * (probably removable devices).
616 let devices = List.filter_map (
618 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
619 let lines = shget cmd in
621 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
622 | Some [] | None -> None
624 eprintf "all_block_devices: non-removable block devices: %s\n%!"
626 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
628 fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
631 (* Search for partitions and LVs (anything that could contain a
632 * filesystem directly). We refer to these generically as
635 let all_partitions : partition list =
638 let lvs = get_lvs () in
639 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
640 let pvs = List.concat pvs in
641 let pvs = sort_uniq pvs in
642 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
643 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
644 eprintf "all_partitions: LVs: %s\n%!"
645 (String.concat "; " (List.map dev_of_partition lvs));
648 (* Partitions (eg. "sda1", "sda2"). *)
650 let parts = List.map fst all_block_devices in
651 let parts = List.map get_partitions parts in
652 let parts = List.concat parts in
653 eprintf "all_partitions: all partitions: %s\n%!"
654 (String.concat "; " (List.map dev_of_partition parts));
656 (* Remove any partitions which are PVs. *)
657 let parts = List.filter (
659 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
660 | LV _ -> assert false
663 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
664 (String.concat "; " (List.map dev_of_partition parts));
666 (* Concatenate LVs & Parts *)
669 (* Try to determine the nature of each partition.
670 * Root? Swap? Architecture? etc.
672 let all_partitions : (partition * nature) list =
673 (* Output of 'file' command for Linux swap file. *)
674 let swap = Pcre.regexp "Linux.*swap.*file" in
675 (* Contents of /etc/redhat-release. *)
676 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
677 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
678 (* Contents of /etc/debian_version. *)
679 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
680 (* Output of 'file' on certain executables. *)
681 let i386 = Pcre.regexp ", Intel 80386," in
682 let x86_64 = Pcre.regexp ", x86-64," in
683 let itanic = Pcre.regexp ", IA-64," in
685 (* Examine the filesystem mounted on 'mnt' to determine the
686 * operating system, and, if Linux, the distro.
689 if is_dir (mnt ^ "/Windows") = Some true &&
690 is_file (mnt ^ "/autoexec.bat") = Some true then
692 else if is_dir (mnt ^ "/etc") = Some true &&
693 is_dir (mnt ^ "/sbin") = Some true &&
694 is_dir (mnt ^ "/var") = Some true then (
695 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
696 let chan = open_in (mnt ^ "/etc/redhat-release") in
697 let lines = input_all_lines chan in
701 | [] -> (* empty /etc/redhat-release ...? *)
702 LinuxRoot (UnknownArch, OtherLinux)
703 | line::_ -> (* try to detect OS from /etc/redhat-release *)
705 let subs = Pcre.exec ~rex:rhel line in
706 let major = int_of_string (Pcre.get_substring subs 1) in
708 try int_of_string (Pcre.get_substring subs 2)
709 with Not_found -> 0 in
710 LinuxRoot (UnknownArch, RHEL (major, minor))
712 Not_found | Failure "int_of_string" ->
714 let subs = Pcre.exec ~rex:fedora line in
715 let version = int_of_string (Pcre.get_substring subs 1) in
716 LinuxRoot (UnknownArch, Fedora version)
718 Not_found | Failure "int_of_string" ->
719 LinuxRoot (UnknownArch, OtherLinux)
721 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
722 let chan = open_in (mnt ^ "/etc/debian_version") in
723 let lines = input_all_lines chan in
727 | [] -> (* empty /etc/debian_version ...? *)
728 LinuxRoot (UnknownArch, OtherLinux)
729 | line::_ -> (* try to detect version from /etc/debian_version *)
731 let subs = Pcre.exec ~rex:debian line in
732 let major = int_of_string (Pcre.get_substring subs 1) in
733 let minor = int_of_string (Pcre.get_substring subs 2) in
734 LinuxRoot (UnknownArch, Debian (major, minor))
736 Not_found | Failure "int_of_string" ->
737 LinuxRoot (UnknownArch, OtherLinux)
740 LinuxRoot (UnknownArch, OtherLinux)
741 ) else if is_dir (mnt ^ "/grub") = Some true &&
742 is_file (mnt ^ "/grub/stage1") = Some true then (
745 NotRoot (* mountable, but not a root filesystem *)
748 (* Examine the Linux root filesystem mounted on 'mnt' to
749 * determine the architecture. We do this by looking at some
750 * well-known binaries that we expect to be there.
752 let detect_architecture mnt =
753 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
755 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
756 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
757 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
763 let dev = dev_of_partition part in (* Get /dev device. *)
766 (* Use 'file' command to detect if it is swap. *)
767 let cmd = "file -sbL " ^ quote dev in
769 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
771 (* Blindly try to mount the device. *)
772 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
773 match shwithstatus cmd with
775 let os = detect_os "/mnt/root" in
778 | LinuxRoot (UnknownArch, distro) ->
779 let architecture = detect_architecture "/mnt/root" in
780 LinuxRoot (architecture, distro)
782 sh "umount /mnt/root";
785 | _ -> UnknownNature (* not mountable *)
789 eprintf "partition detection: %s is %s\n%!"
790 dev (string_of_nature nature);
796 printf "virt-p2v.ml finished detecting hard drives\n%!";
799 let ask_greeting state =
800 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);
804 let ask_hostname state =
806 inputbox "Remote host" "Remote host" 10 50
807 (Option.default "" state.remote_host)
809 | Yes [] -> Ask_again
810 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
811 | No | Help | Error -> Ask_again
817 inputbox "Remote port" "Remote port" 10 50
818 (Option.default "22" state.remote_port)
820 | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
821 | Yes (port::_) -> Next { state with remote_port = Some port }
822 | No | Help | Error -> Ask_again
826 let ask_directory state =
827 let default_dir = "/var/lib/xen/images" in
829 inputbox "Remote directory" "Remote directory" 10 50
830 (Option.default default_dir state.remote_directory)
832 | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
833 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
834 | No | Help | Error -> Ask_again
838 let ask_network state =
840 radiolist "Network configuration" "Network configuration" 10 50 2 [
841 "auto", "Automatic configuration", state.network = Some Auto;
842 "sh", "Configure from the shell", state.network = Some Shell;
845 | Yes ("auto"::_) -> Next { state with network = Some Auto }
846 | Yes ("sh"::_) -> Next { state with network = Some Shell }
847 | Yes _ | No | Help | Error -> Ask_again
851 let ask_devices state =
852 let selected_devices = Option.default [] state.devices_to_send in
853 let devices = List.map (
854 fun (dev, blksize) ->
856 sprintf "/dev/%s (%.3f GB)" dev
857 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
858 List.mem dev selected_devices)
859 ) all_block_devices in
861 checklist "Devices" "Pick devices to send" 15 50 8 devices
863 | Yes [] | No | Help | Error -> Ask_again
864 | Yes devices -> Next { state with devices_to_send = Some devices }
869 let parts = List.mapi (
870 fun i (part, nature) ->
873 | LinuxSwap -> " (Linux swap)"
874 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
875 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
876 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
877 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
878 | WindowsRoot -> " (Windows C:)"
879 | LinuxBoot -> " (Linux /boot)"
880 | NotRoot -> " (filesystem)"
881 | UnknownNature -> "" in
883 dev_of_partition part ^ descr,
884 Some part = state.root_filesystem)
887 radiolist "Root device"
888 "Pick partition containing the root (/) filesystem" 18 70 9
892 let (part, _) = List.nth all_partitions (int_of_string i) in
893 Next { state with root_filesystem = Some part }
894 | Yes [] | No | Help | Error -> Ask_again
898 let ask_hypervisor state =
900 radiolist "Hypervisor"
901 "Choose hypervisor / virtualization system"
903 "xen", "Xen", state.hypervisor = Some Xen;
904 "qemu", "QEMU", state.hypervisor = Some QEMU;
905 "kvm", "KVM", state.hypervisor = Some KVM;
906 "other", "Other", state.hypervisor = None
909 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
910 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
911 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
912 | Yes _ -> Next { state with hypervisor = None }
913 | No | Help | Error -> Ask_again
917 let ask_architecture state =
919 radiolist "Architecture" "Machine architecture" 16 50 8 [
920 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
921 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
922 "ia64", "Itanium IA64", state.architecture = Some IA64;
923 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
924 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
925 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
926 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
927 "auto", "Auto-detect",
928 state.architecture = None || state.architecture = Some UnknownArch;
931 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
932 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
933 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
934 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
935 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
936 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
937 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
938 | Yes _ -> Next { state with architecture = Some UnknownArch }
939 | No | Help | Error -> Ask_again
943 let ask_memory state =
945 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
947 (Option.map_default string_of_int "" state.memory)
949 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
951 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
952 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
953 else Next { state with memory = Some mem }
954 | No | Help | Error -> Ask_again
958 let ask_vcpus state =
960 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
962 (Option.map_default string_of_int "" state.vcpus)
964 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
967 try int_of_string vcpus with Failure "int_of_string" -> -1 in
968 if vcpus < 0 then Ask_again
969 else Next { state with vcpus = Some vcpus }
970 | No | Help | Error -> Ask_again
974 let ask_mac_address state =
976 inputbox "MAC address"
977 "Network MAC address. Leave blank to use a random address." 10 50
978 (Option.default "" state.mac_address)
980 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
981 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
982 | No | Help | Error -> Ask_again
986 let ask_verify state =
988 yesno "Verify and proceed"
989 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1001 (Option.default "" state.remote_host)
1002 (Option.default "" state.remote_port)
1003 (Option.default "" state.remote_directory)
1004 (match state.network with
1005 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1007 (String.concat "," (Option.default [] state.devices_to_send))
1008 (Option.map_default dev_of_partition "" state.root_filesystem)
1009 (match state.hypervisor with
1010 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1011 | None -> "Other / not set")
1012 (match state.architecture with
1013 | Some UnknownArch -> "Auto-detect"
1014 | Some arch -> string_of_architecture arch | None -> "")
1015 (match state.memory with
1016 | Some 0 -> "Same as physical"
1017 | Some mem -> string_of_int mem ^ " MB" | None -> "")
1018 (match state.vcpus with
1019 | Some 0 -> "Same as physical"
1020 | Some vcpus -> string_of_int vcpus | None -> "")
1021 (match state.mac_address with
1022 | Some "" -> "Random" | Some mac -> mac | None -> "")
1026 | Yes _ -> Next state
1028 | No | Help | Error -> Ask_again
1031 (* This is the list of dialogs, in order. The user can go forwards or
1032 * backwards through them. The second parameter in each pair is
1033 * false if we need to skip this dialog (info already supplied in
1034 * 'defaults' above).
1037 ask_greeting, (* Initial greeting. *)
1039 ask_hostname, (* Hostname. *)
1040 defaults.remote_host = None;
1041 ask_port, (* Port number. *)
1042 defaults.remote_port = None;
1043 ask_directory, (* Remote directory. *)
1044 defaults.remote_directory = None;
1045 ask_network, (* Network configuration. *)
1046 defaults.network = None;
1047 ask_devices, (* Block devices to send. *)
1048 defaults.devices_to_send = None;
1049 ask_root, (* Root filesystem. *)
1050 defaults.root_filesystem = None;
1051 ask_hypervisor, (* Hypervisor. *)
1052 defaults.hypervisor = None;
1053 ask_architecture, (* Architecture. *)
1054 defaults.architecture = None;
1055 ask_memory, (* Memory. *)
1056 defaults.memory = None;
1057 ask_vcpus, (* VCPUs. *)
1058 defaults.vcpus = None;
1059 ask_mac_address, (* MAC address. *)
1060 defaults.mac_address = None;
1061 ask_verify, (* Verify settings. *)
1065 (* Loop through the dialogs until we reach the end. *)
1066 let rec loop posn state =
1067 eprintf "dialog loop: posn = %d\n%!" posn;
1068 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1070 let dlg, no_skip = dlgs.(posn) in
1071 let skip = not no_skip in
1073 (* Skip this dialog and move straight to the next one. *)
1077 match dlg state with
1078 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1079 | Prev -> loop (posn-1) state (* Backwards / back button. *)
1080 | Ask_again -> loop posn state (* Repeat the question. *)
1084 let state = loop 0 defaults in
1086 eprintf "finished dialog loop\n%!";
1088 (* Switch LVM config. *)
1090 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1091 sh "rm -f /etc/lvm/cache/.cache";
1092 sh "rm -f /etc/lvm.new/cache/.cache";
1094 (* Snapshot the block devices to send. *)
1095 let devices_to_send = Option.get state.devices_to_send in
1096 let devices_to_send =
1099 let snapshot_dev = snapshot_name origin_dev in
1100 snapshot origin_dev snapshot_dev;
1101 (origin_dev, snapshot_dev)
1102 ) devices_to_send in
1104 (* Run kpartx on the snapshots. *)
1106 fun (origin, snapshot) ->
1107 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1110 (* Rescan for LVs. *)
1114 (* Mount the root filesystem under /mnt/root. *)
1115 let root_filesystem = Option.get state.root_filesystem in
1116 (match root_filesystem with
1117 | Part (dev, partnum) ->
1118 let dev = dev ^ partnum in
1119 let snapshot_dev = snapshot_name dev in
1120 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1123 (* The LV will be backed by a snapshot device, so just mount
1126 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1129 (* See if we can do network configuration. *)
1130 let network = Option.get state.network in
1133 printf "Network configuration.\n\n";
1134 printf "Please configure the network from this shell.\n\n";
1135 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1140 "Trying network auto-configuration from root filesystem ...\n\n%!";
1141 if not (auto_network state) then (
1142 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1143 printf "Please configure the network from this shell.\n\n";
1144 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1149 (* Work out what devices will be called at the remote end. *)
1150 let devices_to_send = List.map (
1151 fun (origin_dev, snapshot_dev) ->
1152 let remote_dev = remote_of_origin_dev origin_dev in
1153 (origin_dev, snapshot_dev, remote_dev)
1154 ) devices_to_send in
1156 (* Modify files on the root filesystem. *)
1157 rewrite_fstab state devices_to_send;
1158 (* XXX Other files to rewrite? *)
1160 (* XXX Autodetect architecture of root filesystem by looking for /bin/ls. *)
1161 let system_architecture = X86_64 in
1163 (* XXX Autodetect system memory. *)
1164 let system_memory = 256 in
1166 (* XXX Autodetect system # pCPUs. *)
1167 let system_nr_cpus = 1 in
1169 (* Unmount the root filesystem and sync disks. *)
1170 sh "umount /mnt/root";
1171 sh "sync"; (* Ugh, should be in stdlib. *)
1173 (* Disable screen blanking on console. *)
1174 sh "setterm -blank 0";
1176 let remote_host = Option.get state.remote_host in
1177 let remote_port = Option.get state.remote_port in
1178 let remote_directory = Option.get state.remote_directory in
1180 (* Functions to connect and disconnect from the remote system. *)
1181 let do_connect remote_name _ =
1182 let cmd = sprintf "ssh -C -p %s %s \"cat > %s/%s\""
1183 (quote remote_port) (quote remote_host)
1184 (quote remote_directory) (quote remote_name) in
1185 eprintf "connect: %s\n%!" cmd;
1186 let chan = open_process_out cmd in
1187 descr_of_out_channel chan, chan
1189 let do_disconnect (_, chan) =
1190 match close_process_out chan with
1191 | WEXITED 0 -> () (* OK *)
1192 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1193 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1194 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1197 (* XXX This is using the hostname derived from network configuration
1198 * above. We might want to ask the user to choose.
1200 let hostname = safe_name (gethostname ()) in
1202 let date = sprintf "%04d%02d%02d%02d%02d"
1203 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1204 "p2v-" ^ hostname ^ "-" ^ date in
1206 (* Work out what the image filenames will be at the remote end. *)
1207 let devices_to_send = List.map (
1208 fun (origin_dev, snapshot_dev, remote_dev) ->
1209 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1210 (origin_dev, snapshot_dev, remote_dev, remote_name)
1211 ) devices_to_send in
1213 (* Write a configuration file. Not sure if this is any better than
1214 * just 'sprintf-ing' bits of XML text together, but at least we will
1215 * always get well-formed XML.
1217 * XXX For some of the stuff here we really should do a
1218 * virConnectGetCapabilities call to the remote host first.
1220 * XXX There is a case for using virt-install to generate this XML.
1221 * When we start to incorporate libvirt access & storage API this
1222 * needs to be rethought.
1224 let conf_filename = basename ^ ".conf" in
1227 match state.architecture with
1228 | Some UnknownArch | None -> system_architecture
1229 | Some arch -> arch in
1231 match state.memory with
1232 | Some 0 | None -> system_memory
1233 | Some memory -> memory in
1235 match state.vcpus with
1236 | Some 0 | None -> system_nr_cpus
1239 match state.mac_address with
1242 List.map (sprintf "%02x") (
1243 List.map (fun _ -> Random.int 256) [0;0;0]
1245 String.concat ":" ("00"::"16"::"3e"::random)
1246 | Some mac -> mac in
1249 (* Shortcut to make "<name>value</name>". *)
1250 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1251 (* ... and the _other_ sort of leaf (god I hate XML). *)
1252 let tleaf name attribs = Xml.Element (name, attribs, []) in
1254 (* Standard stuff for every domain. *)
1255 let name = leaf "name" hostname in
1256 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1257 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1259 (* Top-level stuff which differs for each HV type (isn't this supposed
1260 * to be portable ...)
1263 match state.hypervisor with
1265 [Xml.Element ("os", [],
1267 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1268 tleaf "boot" ["dev", "hd"]]);
1269 Xml.Element ("features", [],
1273 tleaf "clock" ["sync", "localtime"]]
1275 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1276 tleaf "clock" ["sync", "localtime"]]
1278 [Xml.Element ("os", [],
1279 [Xml.Element ("type",
1281 string_of_architecture architecture;
1283 [Xml.PCData "hvm"]);
1284 tleaf "boot" ["dev", "hd"]])]
1288 (* <devices> section. *)
1291 match state.hypervisor with
1293 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1295 [leaf "emulator" "/usr/bin/qemu"]
1297 [leaf "emulator" "/usr/bin/qemu-kvm"]
1301 Xml.Element ("interface", ["type", "user"],
1302 [tleaf "mac" ["address", mac_address]]) in
1303 (* XXX should have an option for Xen bridging:
1305 "interface", ["type","bridge"],
1306 [tleaf "source" ["bridge","xenbr0"];
1307 tleaf "mac" ["address",mac_address];
1308 tleaf "script" ["path","vif-bridge"]])*)
1309 let graphics = tleaf "graphics" ["type", "vnc"] in
1311 let disks = List.map (
1312 fun (_, _, remote_dev, remote_name) ->
1314 "disk", ["type", "file";
1316 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1317 tleaf "target" ["dev", remote_dev]]
1319 ) devices_to_send in
1323 emulator @ interface :: graphics :: disks
1326 (* Put it all together in <domain type='foo'>. *)
1329 (match state.hypervisor with
1330 | Some Xen -> ["type", "xen"]
1331 | Some QEMU -> ["type", "qemu"]
1332 | Some KVM -> ["type", "kvm"]
1334 name :: memory :: vcpu :: extras @ [devices]
1337 let xml = Xml.to_string_fmt xml in
1338 let xml_len = String.length xml in
1339 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1341 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1342 (* In OCaml this actually loops calling write(2) *)
1343 ignore (write sock xml 0 xml_len);
1346 (* Send the device snapshots to the remote host. *)
1347 (* XXX This code should be made more robust against both network
1348 * errors and local I/O errors. Also should allow the user several
1349 * attempts to connect, or let them go back to the dialog stage.
1352 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1353 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1356 try List.assoc origin_dev all_block_devices
1357 with Not_found -> assert false (* internal error *) in
1359 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1360 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1362 (* Open the snapshot device. *)
1363 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1366 let (sock,_) as conn = do_connect remote_name size in
1368 (* Copy the data. *)
1369 let bufsize = 1024 * 1024 in
1370 let buffer = String.create bufsize in
1371 let start = gettimeofday () in
1373 let rec copy bytes_sent last_printed_at =
1374 let n = read fd buffer 0 bufsize in
1376 ignore (write sock buffer 0 n);
1378 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1379 let last_printed_at =
1380 let now = gettimeofday () in
1381 (* Print progress once per second. *)
1382 if now -. last_printed_at > 1. then (
1383 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1384 let secs_elapsed = now -. start in
1385 printf "%.0f%%" (100. *. elapsed);
1386 (* After 60 seconds has elapsed, start printing estimates. *)
1387 if secs_elapsed >= 60. then (
1388 let remaining = 1. -. elapsed in
1389 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1390 if secs_remaining > 120. then
1391 printf " (about %.0f minutes remaining) "
1392 (secs_remaining /. 60.)
1394 printf " (about %.0f seconds remaining) "
1400 else last_printed_at in
1402 copy bytes_sent last_printed_at
1411 (* Clean up and reboot. *)
1413 msgbox "virt-p2v completed"
1414 (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."
1415 remote_directory conf_filename)
1424 eprintf "usage: virt-p2v [ttyname]\n%!";
1427 (* Make sure that exceptions from 'main' get printed out on stdout
1428 * as well as stderr, since stderr is probably redirected to the
1429 * logfile, and so not visible to the user.
1431 let handle_exn f arg =
1433 with exn -> print_endline (Printexc.to_string exn); raise exn
1435 (* If the ISO image has an attachment then it could be a new version
1436 * of virt-p2v.ml (this script). Get the attachment and run it
1437 * instead. Useful mainly for testing, in conjunction with the
1438 * 'make update' target in the virt-p2v Makefile.
1440 let magic = "ISOATTACHMENT002"
1441 let magiclen = String.length magic (* = 16 bytes *)
1442 let trailerlen = magiclen + 8 + 8 (* magic + file start + true size *)
1444 let int64_of_string str =
1446 let add offs shift =
1449 (Int64.shift_left (Int64.of_int (Char.code str.[offs])) shift) !i
1451 add 0 56; add 1 48; add 2 40; add 3 32;
1452 add 4 24; add 5 16; add 6 8; add 7 0;
1455 let update ttyname =
1456 let cdrom = "/dev/cdrom" in
1457 let output = "/tmp/virt-p2v.ml" in
1460 let fd = openfile cdrom [O_RDONLY] 0 in
1461 ignore (LargeFile.lseek fd (Int64.of_int ~-trailerlen) SEEK_END);
1462 let buf = String.create magiclen in
1463 if read fd buf 0 magiclen <> magiclen || buf <> magic then (
1468 (* Read the size. *)
1469 let buf = String.create 8 in
1470 if read fd buf 0 8 <> 8 then
1471 failwith "cannot read attachment offset";
1472 let offset = int64_of_string buf in
1473 let buf = String.create 8 in
1474 if read fd buf 0 8 <> 8 then
1475 failwith "cannot read attachment size";
1476 let size = Int64.to_int (int64_of_string buf) in
1478 (* Seek to beginning of the attachment. *)
1479 ignore (LargeFile.lseek fd offset SEEK_SET);
1481 (* Copy out the attachment. *)
1482 let fd2 = openfile output [O_WRONLY; O_CREAT; O_TRUNC] 0o755 in
1483 let bufsize = 4 * 1024 in
1484 let buffer = String.create bufsize in
1485 let rec copy remaining =
1486 if remaining > 0 then (
1487 let n = min remaining bufsize in
1488 let n = read fd buffer 0 n in
1489 if n = 0 then failwith "corrupted or partial attachment";
1490 ignore (write fd2 buffer 0 n);
1491 copy (remaining - n)
1499 (* Run updated virt-p2v script. *)
1500 execv output [| output; ttyname |]
1502 Unix_error _ | Exit ->
1503 (* Some error, or no attachment, so keep running this script. *)
1504 handle_exn main (Some ttyname)
1506 (* Test harness for the Makefile. The Makefile invokes this script as
1507 * 'virt-p2v.ml --test' just to check it compiles. When it is running
1508 * from the actual live CD, there is a single parameter which is the
1509 * tty name (so usually 'virt-p2v.ml tty1').
1512 match Array.to_list Sys.argv with
1513 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1514 | [ _; "--update"; ttyname ] -> (* Test for update and run. *)
1516 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1517 | [ _; ttyname ] -> (* Run main with ttyname. *)
1518 handle_exn main (Some ttyname)
1519 | [ _ ] -> (* Interactive - no ttyname. *)
1520 handle_exn main None
1523 (* This file must end with a newline *)