X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=sparsify%2Fsparsify.ml;h=9a46495e5c80040f3597f3a9b1f42c72e0d4f8bf;hb=82aec3fd43d3300bb8e60fe325486451defd5c45;hp=4782983dcc82bad1f6e742ad0166ab440d089fbd;hpb=b0605f265be3f501930516ff95deab2910ced3ac;p=libguestfs.git

diff --git a/sparsify/sparsify.ml b/sparsify/sparsify.ml
index 4782983..9a46495 100644
--- a/sparsify/sparsify.ml
+++ b/sparsify/sparsify.ml
@@ -28,7 +28,8 @@ let () = Random.self_init ()
 (* Command line argument parsing. *)
 let prog = Filename.basename Sys.executable_name
 
-let indisk, outdisk, convert, format, ignores, machine_readable, quiet,
+let indisk, outdisk, convert, debug_gc,
+  format, ignores, machine_readable, quiet,
   verbose, trace =
   let display_version () =
     let g = new G.guestfs () in
@@ -41,6 +42,7 @@ let indisk, outdisk, convert, format, ignores, machine_readable, quiet,
   let add xs s = xs := s :: !xs 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
@@ -50,6 +52,7 @@ let indisk, outdisk, convert, format, ignores, machine_readable, quiet,
 
   let argspec = Arg.align [
     "--convert", Arg.Set_string convert,    "format Format of output disk (default: same as input)";
+    "--debug-gc", Arg.Set debug_gc,         " Debug GC and memory allocations";
     "--format",  Arg.Set_string format,     "format Format of input disk";
     "--ignore",  Arg.String (add ignores),  "fs Ignore filesystem";
     "--machine-readable", Arg.Set machine_readable, " Make output machine readable";
@@ -77,6 +80,7 @@ read the man page virt-sparsify(1).
 
   (* Dereference the rest of the args. *)
   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
@@ -122,8 +126,9 @@ read the man page virt-sparsify(1).
   if contains_comma then
     error "input filename '%s' contains a comma; qemu-img command line syntax prevents us from using such an image" indisk;
 
-  indisk, outdisk, convert, format, ignores, machine_readable, quiet,
-  verbose, trace
+  indisk, outdisk, convert,
+    debug_gc, format, ignores, machine_readable, quiet,
+    verbose, trace
 
 let () =
   if not quiet then
@@ -274,6 +279,8 @@ let output_format =
       );
       if string_prefix line "QEMU QCOW Image (v2)" then
         "qcow2"
+      else if string_find line "VirtualBox" >= 0 then
+        "vdi"
       else
         "raw" (* XXX guess *)
 
@@ -300,4 +307,7 @@ let () =
     wrap "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 ();
+
   exit 0