6:13 p.m.
This is just code motion, there is no functional change.
---
sparsify/sparsify.ml | 418 ++++++++++++++++++++++++++-------------------------
1 file changed, 217 insertions(+), 201 deletions(-)
diff --git a/sparsify/sparsify.ml b/sparsify/sparsify.ml
index b124406..e79fe78 100644
--- a/sparsify/sparsify.ml
+++ b/sparsify/sparsify.ml
@@ -31,68 +31,69 @@ external statvfs_free_space : string -> int64 =
let () = Random.self_init ()
-(* Command line argument parsing. *)
let prog = Filename.basename Sys.executable_name
let error fs = error ~prog fs
-let indisk, outdisk, check_tmpdir, compress, convert, debug_gc,
- format, ignores, machine_readable,
- option, quiet, verbose, trace, zeroes =
- let display_version () =
- printf "virt-sparsify %s\n" Config.package_version;
- exit 0
- in
+let main () =
+ (* Command line argument parsing. *)
+ let indisk, outdisk, check_tmpdir, compress, convert, debug_gc,
+ format, ignores, machine_readable,
+ option, quiet, verbose, trace, zeroes =
+ let display_version () =
+ printf "virt-sparsify %s\n" Config.package_version;
+ exit 0
+ in
- let add xs s = xs := s :: !xs in
+ let add xs s = xs := s :: !xs in
- let check_tmpdir = ref `Warn in
- let set_check_tmpdir = function
- | "ignore" | "i" -> check_tmpdir := `Ignore
- | "continue" | "cont" | "c" -> check_tmpdir :=
`Continue
- | "warn" | "warning" | "w" -> check_tmpdir := `Warn
- | "fail" | "f" | "error" -> check_tmpdir := `Fail
- | str ->
- eprintf (f_"--check-tmpdir: unknown argument `%s'\n") str;
- exit 1
- in
+ let check_tmpdir = ref `Warn in
+ let set_check_tmpdir = function
+ | "ignore" | "i" -> check_tmpdir := `Ignore
+ | "continue" | "cont" | "c" -> check_tmpdir :=
`Continue
+ | "warn" | "warning" | "w" -> check_tmpdir :=
`Warn
+ | "fail" | "f" | "error" -> check_tmpdir := `Fail
+ | str ->
+ eprintf (f_"--check-tmpdir: unknown argument `%s'\n") str;
+ exit 1
+ in
- let compress = ref false in
- let convert = ref "" in
- let debug_gc = ref false in
- let format = ref "" in
- let ignores = ref [] in
- let machine_readable = ref false in
- let option = ref "" in
- let quiet = ref false in
- let verbose = ref false in
- let trace = ref false in
- let zeroes = ref [] in
+ let compress = ref false in
+ let convert = ref "" in
+ let debug_gc = ref false in
+ let format = ref "" in
+ let ignores = ref [] in
+ let machine_readable = ref false in
+ let option = ref "" in
+ let quiet = ref false in
+ let verbose = ref false in
+ let trace = ref false in
+ let zeroes = ref [] in
- let ditto = " -\"-" in
- let argspec = Arg.align [
- "--check-tmpdir", Arg.String set_check_tmpdir, "ignore|..." ^
" " ^ s_"Check there is enough space in $TMPDIR";
- "--compress", Arg.Set compress, " " ^ s_"Compressed
output format";
- "--convert", Arg.Set_string convert, s_"format" ^ "
" ^ s_"Format of output disk (default: same as input)";
- "--debug-gc", Arg.Set debug_gc, " " ^ s_"Debug GC
and memory allocations";
- "--format", Arg.Set_string format, s_"format" ^ "
" ^ s_"Format of input disk";
- "--ignore", Arg.String (add ignores), s_"fs" ^ " " ^
s_"Ignore filesystem";
- "--long-options", Arg.Unit display_long_options, " " ^
s_"List long options";
- "--machine-readable", Arg.Set machine_readable, " " ^
s_"Make output machine readable";
- "-o", Arg.Set_string option, s_"option" ^ "
" ^ s_"Add qemu-img options";
- "-q", Arg.Set quiet, " " ^ s_"Quiet
output";
- "--quiet", Arg.Set quiet, ditto;
- "-v", Arg.Set verbose, " " ^ s_"Enable
debugging messages";
- "--verbose", Arg.Set verbose, ditto;
- "-V", Arg.Unit display_version, " " ^ s_"Display
version and exit";
- "--version", Arg.Unit display_version, ditto;
- "-x", Arg.Set trace, " " ^ s_"Enable
tracing of libguestfs calls";
- "--zero", Arg.String (add zeroes), s_"fs" ^ " " ^
s_"Zero filesystem";
- ] in
- long_options := argspec;
- let disks = ref [] in
- let anon_fun s = disks := s :: !disks in
- let usage_msg =
- sprintf (f_"\
+ let ditto = " -\"-" in
+ let argspec = Arg.align [
+ "--check-tmpdir", Arg.String set_check_tmpdir, "ignore|..." ^
" " ^ s_"Check there is enough space in $TMPDIR";
+ "--compress", Arg.Set compress, " " ^
s_"Compressed output format";
+ "--convert", Arg.Set_string convert, s_"format" ^ "
" ^ s_"Format of output disk (default: same as input)";
+ "--debug-gc", Arg.Set debug_gc, " " ^ s_"Debug GC
and memory allocations";
+ "--format", Arg.Set_string format, s_"format" ^ "
" ^ s_"Format of input disk";
+ "--ignore", Arg.String (add ignores), s_"fs" ^ " "
^ s_"Ignore filesystem";
+ "--long-options", Arg.Unit display_long_options, " " ^
s_"List long options";
+ "--machine-readable", Arg.Set machine_readable, " " ^
s_"Make output machine readable";
+ "-o", Arg.Set_string option, s_"option" ^ "
" ^ s_"Add qemu-img options";
+ "-q", Arg.Set quiet, " " ^ s_"Quiet
output";
+ "--quiet", Arg.Set quiet, ditto;
+ "-v", Arg.Set verbose, " " ^ s_"Enable
debugging messages";
+ "--verbose", Arg.Set verbose, ditto;
+ "-V", Arg.Unit display_version, " " ^ s_"Display
version and exit";
+ "--version", Arg.Unit display_version, ditto;
+ "-x", Arg.Set trace, " " ^ s_"Enable
tracing of libguestfs calls";
+ "--zero", Arg.String (add zeroes), s_"fs" ^ " "
^ s_"Zero filesystem";
+ ] in
+ long_options := argspec;
+ let disks = ref [] in
+ let anon_fun s = disks := s :: !disks in
+ let usage_msg =
+ sprintf (f_"\
%s: sparsify a virtual machine disk
virt-sparsify [--options] indisk outdisk
@@ -100,118 +101,114 @@ let indisk, outdisk, check_tmpdir, compress, convert, debug_gc,
A short summary of the options is given below. For detailed help please
read the man page virt-sparsify(1).
")
- prog in
- Arg.parse argspec anon_fun usage_msg;
+ prog in
+ Arg.parse argspec anon_fun usage_msg;
- (* Dereference the rest of the args. *)
- let check_tmpdir = !check_tmpdir in
- let compress = !compress in
- let convert = match !convert with "" -> None | str -> Some str in
- let debug_gc = !debug_gc in
- let format = match !format with "" -> None | str -> Some str in
- let ignores = List.rev !ignores in
- let machine_readable = !machine_readable in
- let option = match !option with "" -> None | str -> Some str in
- let quiet = !quiet in
- let verbose = !verbose in
- let trace = !trace in
- let zeroes = List.rev !zeroes in
+ (* Dereference the rest of the args. *)
+ let check_tmpdir = !check_tmpdir in
+ let compress = !compress in
+ let convert = match !convert with "" -> None | str -> Some str in
+ let debug_gc = !debug_gc in
+ let format = match !format with "" -> None | str -> Some str in
+ let ignores = List.rev !ignores in
+ let machine_readable = !machine_readable in
+ let option = match !option with "" -> None | str -> Some str in
+ let quiet = !quiet in
+ let verbose = !verbose in
+ let trace = !trace in
+ let zeroes = List.rev !zeroes in
- (* No arguments and machine-readable mode? Print out some facts
- * about what this binary supports.
- *)
- if !disks = [] && machine_readable then (
- printf "virt-sparsify\n";
- printf "linux-swap\n";
- printf "zero\n";
- printf "check-tmpdir\n";
- let g = new G.guestfs () in
- g#add_drive "/dev/null";
- g#launch ();
- if g#feature_available [| "ntfsprogs"; "ntfs3g" |] then
- printf "ntfs\n";
- if g#feature_available [| "btrfs" |] then
- printf "btrfs\n";
- exit 0
- );
+ (* No arguments and machine-readable mode? Print out some facts
+ * about what this binary supports.
+ *)
+ if !disks = [] && machine_readable then (
+ printf "virt-sparsify\n";
+ printf "linux-swap\n";
+ printf "zero\n";
+ printf "check-tmpdir\n";
+ let g = new G.guestfs () in
+ g#add_drive "/dev/null";
+ g#launch ();
+ if g#feature_available [| "ntfsprogs"; "ntfs3g" |] then
+ printf "ntfs\n";
+ if g#feature_available [| "btrfs" |] then
+ printf "btrfs\n";
+ exit 0
+ );
- (* Verify we got exactly 2 disks. *)
- let indisk, outdisk =
- match List.rev !disks with
- | [indisk; outdisk] -> indisk, outdisk
- | _ ->
+ (* Verify we got exactly 2 disks. *)
+ let indisk, outdisk =
+ match List.rev !disks with
+ | [indisk; outdisk] -> indisk, outdisk
+ | _ ->
error "usage is: %s [--options] indisk outdisk" prog in
- (* Simple-minded check that the user isn't trying to use the
- * same disk for input and output.
- *)
- if indisk = outdisk then
- error (f_"you cannot use the same disk image for input and output");
+ (* Simple-minded check that the user isn't trying to use the
+ * same disk for input and output.
+ *)
+ if indisk = outdisk then
+ error (f_"you cannot use the same disk image for input and output");
- (* The input disk must be an absolute path, so we can store the name
- * in the overlay disk.
- *)
- let indisk =
- if not (Filename.is_relative indisk) then
- indisk
- else
- Sys.getcwd () // indisk in
+ (* The input disk must be an absolute path, so we can store the name
+ * in the overlay disk.
+ *)
+ let indisk =
+ if not (Filename.is_relative indisk) then
+ indisk
+ else
+ Sys.getcwd () // indisk in
- (* Check the output is not a block or char special (RHBZ#1056290). *)
- if is_block_device outdisk then
- error (f_"output '%s' cannot be a block device, it must be a regular
file")
- outdisk;
+ (* Check the output is not a block or char special (RHBZ#1056290). *)
+ if is_block_device outdisk then
+ error (f_"output '%s' cannot be a block device, it must be a regular
file")
+ outdisk;
- if is_char_device outdisk then
- error (f_"output '%s' cannot be a character device, it must be a regular
file")
- outdisk;
+ if is_char_device outdisk then
+ error (f_"output '%s' cannot be a character device, it must be a
regular file")
+ outdisk;
- indisk, outdisk, check_tmpdir, compress, convert,
- debug_gc, format, ignores, machine_readable,
- option, quiet, verbose, trace, zeroes
+ indisk, outdisk, check_tmpdir, compress, convert,
+ debug_gc, format, ignores, machine_readable,
+ option, quiet, verbose, trace, zeroes in
-(* Once we have got past argument parsing and start to create
- * temporary files (including the potentially massive overlay file), we
- * need to catch SIGINT (^C) and exit cleanly so the temporary file
- * goes away. Note that we don't delete temporaries in the signal
- * handler.
- *)
-let () =
+ (* Once we have got past argument parsing and start to create
+ * temporary files (including the potentially massive overlay file), we
+ * need to catch SIGINT (^C) and exit cleanly so the temporary file
+ * goes away. Note that we don't delete temporaries in the signal
+ * handler.
+ *)
let do_sigint _ = exit 1 in
- Sys.set_signal Sys.sigint (Sys.Signal_handle do_sigint)
+ Sys.set_signal Sys.sigint (Sys.Signal_handle do_sigint);
-(* What should the output format be? If the user specified an
- * input format, use that, else detect it from the source image.
- *)
-let output_format =
- match convert with
- | Some fmt -> fmt (* user specified output conversion *)
- | None ->
- match format with
- | Some fmt -> fmt (* user specified input format, use that *)
+ (* What should the output format be? If the user specified an
+ * input format, use that, else detect it from the source image.
+ *)
+ let output_format =
+ match convert with
+ | Some fmt -> fmt (* user specified output conversion *)
| None ->
- (* Don't know, so we must autodetect. *)
- match (new G.guestfs ())#disk_format indisk with
- | "unknown" ->
- error (f_"cannot detect input disk format; use the --format
parameter")
- | fmt -> fmt
+ match format with
+ | Some fmt -> fmt (* user specified input format, use that *)
+ | None ->
+ (* Don't know, so we must autodetect. *)
+ match (new G.guestfs ())#disk_format indisk with
+ | "unknown" ->
+ error (f_"cannot detect input disk format; use the --format
parameter")
+ | fmt -> fmt in
-(* Compression is not supported by raw output (RHBZ#852194). *)
-let () =
+ (* Compression is not supported by raw output (RHBZ#852194). *)
if output_format = "raw" && compress then
- error (f_"--compress cannot be used for raw output. Remove this option or use
--convert qcow2.")
+ error (f_"--compress cannot be used for raw output. Remove this option or use
--convert qcow2.");
-(* Get virtual size of the input disk. *)
-let virtual_size = (new G.guestfs ())#disk_virtual_size indisk
-let () =
+ (* Get virtual size of the input disk. *)
+ let virtual_size = (new G.guestfs ())#disk_virtual_size indisk in
if not quiet then
printf (f_"Input disk virtual size = %Ld bytes (%s)\n%!")
- virtual_size (human_size virtual_size)
+ virtual_size (human_size virtual_size);
-(* Check there is enough space in $TMPDIR. *)
-let tmpdir = Filename.temp_dir_name
+ (* Check there is enough space in $TMPDIR. *)
+ let tmpdir = Filename.temp_dir_name in
-let () =
let print_warning () =
let free_space = statvfs_free_space tmpdir in
let extra_needed = virtual_size -^ free_space in
@@ -236,7 +233,7 @@ You can ignore this warning or change it to a hard failure using the
) else false
in
- match check_tmpdir with
+ (match check_tmpdir with
| `Ignore -> ()
| `Continue -> ignore (print_warning ())
| `Warn ->
@@ -249,57 +246,54 @@ You can ignore this warning or change it to a hard failure using
the
eprintf "Exiting because --check-tmpdir=fail was set.\n%!";
exit 2
)
+ );
-let () =
if not quiet then
- printf (f_"Create overlay file in %s to protect source disk ...\n%!")
tmpdir
+ printf (f_"Create overlay file in %s to protect source disk ...\n%!")
tmpdir;
-(* Create the temporary overlay file. *)
-let overlaydisk =
- let tmp = Filename.temp_file "sparsify" ".qcow2" in
- unlink_on_exit tmp;
+ (* Create the temporary overlay file. *)
+ let overlaydisk =
+ let tmp = Filename.temp_file "sparsify" ".qcow2" in
+ unlink_on_exit tmp;
- (* Create it with the indisk as the backing file. *)
- (* XXX Old code used to:
- * - detect if compat=1.1 was supported
- * - add lazy_refcounts option
- *)
- (new G.guestfs ())#disk_create
- ~backingfile:indisk ?backingformat:format ~compat:"1.1"
- tmp "qcow2" Int64.minus_one;
+ (* Create it with the indisk as the backing file. *)
+ (* XXX Old code used to:
+ * - detect if compat=1.1 was supported
+ * - add lazy_refcounts option
+ *)
+ (new G.guestfs ())#disk_create
+ ~backingfile:indisk ?backingformat:format ~compat:"1.1"
+ tmp "qcow2" Int64.minus_one;
- tmp
+ tmp in
-let () =
if not quiet then
- printf (f_"Examine source disk ...\n%!")
+ printf (f_"Examine source disk ...\n%!");
-(* Connect to libguestfs. *)
-let g =
- let g = new G.guestfs () in
- if trace then g#set_trace true;
- if verbose then g#set_verbose true;
+ (* Connect to libguestfs. *)
+ let g =
+ let g = new G.guestfs () in
+ if trace then g#set_trace true;
+ if verbose then g#set_verbose true;
- (* Note that the temporary overlay disk is always qcow2 format. *)
- g#add_drive ~format:"qcow2" ~readonly:false ~cachemode:"unsafe"
overlaydisk;
+ (* Note that the temporary overlay disk is always qcow2 format. *)
+ g#add_drive ~format:"qcow2" ~readonly:false ~cachemode:"unsafe"
overlaydisk;
- if not quiet then Progress.set_up_progress_bar ~machine_readable g;
- g#launch ();
+ if not quiet then Progress.set_up_progress_bar ~machine_readable g;
+ g#launch ();
- g
+ g in
-(* Modify SIGINT handler (set first above) to cancel the handle. *)
-let () =
+ (* Modify SIGINT handler (set first above) to cancel the handle. *)
let do_sigint _ =
g#user_cancel ();
exit 1
in
- Sys.set_signal Sys.sigint (Sys.Signal_handle do_sigint)
+ Sys.set_signal Sys.sigint (Sys.Signal_handle do_sigint);
-(* Write zeroes for non-ignored filesystems that we are able to mount,
- * and selected swap partitions.
- *)
-let () =
+ (* Write zeroes for non-ignored filesystems that we are able to mount,
+ * and selected swap partitions.
+ *)
let filesystems = g#list_filesystems () in
let filesystems = List.map fst filesystems in
let filesystems = List.sort compare filesystems in
@@ -356,10 +350,9 @@ let () =
g#umount_all ()
)
- ) filesystems
+ ) filesystems;
-(* Fill unused space in volume groups. *)
-let () =
+ (* Fill unused space in volume groups. *)
let vgs = g#vgs () in
let vgs = Array.to_list vgs in
let vgs = List.sort compare vgs in
@@ -382,22 +375,19 @@ let () =
g#lvremove lvdev
)
)
- ) vgs
+ ) vgs;
-(* Don't need libguestfs now. *)
-let () =
+ (* Don't need libguestfs now. *)
g#shutdown ();
- g#close ()
+ g#close ();
-(* Modify SIGINT handler (set first above) to just exit. *)
-let () =
+ (* Modify SIGINT handler (set first above) to just exit. *)
let do_sigint _ = exit 1 in
- Sys.set_signal Sys.sigint (Sys.Signal_handle do_sigint)
+ Sys.set_signal Sys.sigint (Sys.Signal_handle do_sigint);
-(* Now run qemu-img convert which copies the overlay to the
- * destination and automatically does sparsification.
- *)
-let () =
+ (* Now run qemu-img convert which copies the overlay to the
+ * destination and automatically does sparsification.
+ *)
if not quiet then
printf (f_"Copy to destination and make sparse ...\n%!");
@@ -412,16 +402,42 @@ let () =
if verbose then
printf "%s\n%!" cmd;
if Sys.command cmd <> 0 then
- error (f_"external command failed: %s") cmd
+ error (f_"external command failed: %s") cmd;
-(* Finished. *)
-let () =
+ (* Finished. *)
if not quiet then (
print_newline ();
wrap (s_"Sparsify operation completed with no errors. Before deleting the old
disk, carefully check that the target disk boots and works correctly.\n");
);
if debug_gc then
- Gc.compact ();
+ Gc.compact ()
- exit 0
+let () =
+ try main ()
+ with
+ | Unix.Unix_error (code, fname, "") -> (* from a syscall *)
+ eprintf (f_"%s: error: %s: %s\n") prog fname (Unix.error_message code);
+ exit 1
+ | Unix.Unix_error (code, fname, param) -> (* from a syscall *)
+ eprintf (f_"%s: error: %s: %s: %s\n") prog fname (Unix.error_message code)
+ param;
+ exit 1
+ | G.Error msg -> (* from libguestfs *)
+ eprintf (f_"%s: libguestfs error: %s\n") prog msg;
+ exit 1
+ | Failure msg -> (* from failwith/failwithf *)
+ eprintf (f_"%s: failure: %s\n") prog msg;
+ exit 1
+ | Invalid_argument msg -> (* probably should never happen *)
+ eprintf (f_"%s: internal error: invalid argument: %s\n") prog msg;
+ exit 1
+ | Assert_failure (file, line, char) -> (* should never happen *)
+ eprintf (f_"%s: internal error: assertion failed at %s, line %d, char
%d\n") prog file line char;
+ exit 1
+ | Not_found -> (* should never happen *)
+ eprintf (f_"%s: internal error: Not_found exception was thrown\n") prog;
+ exit 1
+ | exn -> (* something not matched above *)
+ eprintf (f_"%s: exception: %s\n") prog (Printexc.to_string exn);
+ exit 1
--
1.8.5.3