extra-tests: Add an extra suppression for OCaml 3.11.2 in RHEL 6.

[libguestfs.git] / resize / resize.ml

diff --git a/resize/resize.ml b/resize/resize.ml
index 9976ff4..6d97553 100644 (file)
--- a/resize/resize.ml
+++ b/resize/resize.ml
@@ -30,7 +30,8 @@ let prog = Filename.basename Sys.executable_name
 
 type align_first_t = [ `Never | `Always | `Auto ]
 
-let infile, outfile, align_first, alignment, copy_boot_loader, debug, deletes,
+let infile, outfile, align_first, alignment, copy_boot_loader,
+  debug, debug_gc, deletes,
   dryrun, expand, expand_content, extra_partition, format, ignores,
   lv_expands, machine_readable, ntfsresize_force, output_format,
   quiet, resizes, resizes_force, shrink =
@@ -48,6 +49,7 @@ let infile, outfile, align_first, alignment, copy_boot_loader, debug, deletes,
   let alignment = ref 128 in
   let copy_boot_loader = ref true in
   let debug = ref false in
+  let debug_gc = ref false in
   let deletes = ref [] in
   let dryrun = ref false in
   let expand = ref "" in
@@ -80,6 +82,7 @@ let infile, outfile, align_first, alignment, copy_boot_loader, debug, deletes,
     "--no-copy-boot-loader", Arg.Clear copy_boot_loader, " Don't copy boot loader";
     "-d",        Arg.Set debug,             " Enable debugging messages";
     "--debug",   Arg.Set debug,             " -\"-";
+    "--debug-gc",Arg.Set debug_gc,          " Debug GC and memory allocations";
     "--delete",  Arg.String (add deletes),  "part Delete partition";
     "--expand",  Arg.String set_expand,     "part Expand partition";
     "--no-expand-content", Arg.Clear expand_content, " Don't expand content";
@@ -126,6 +129,7 @@ read the man page virt-resize(1).
   (* Dereference the rest of the args. *)
   let alignment = !alignment in
   let copy_boot_loader = !copy_boot_loader in
+  let debug_gc = !debug_gc in
   let deletes = List.rev !deletes in
   let dryrun = !dryrun in
   let expand = match !expand with "" -> None | str -> Some str in
@@ -183,7 +187,8 @@ read the man page virt-resize(1).
     | _ ->
         error "usage is: %s [--options] indisk outdisk" prog in
 
-  infile, outfile, align_first, alignment, copy_boot_loader, debug, deletes,
+  infile, outfile, align_first, alignment, copy_boot_loader,
+  debug, debug_gc, deletes,
   dryrun, expand, expand_content, extra_partition, format, ignores,
   lv_expands, machine_readable, ntfsresize_force, output_format,
   quiet, resizes, resizes_force, shrink
@@ -866,20 +871,41 @@ let () =
 
 (* Are we going to align the first partition and fix the bootloader? *)
 let align_first_partition_and_fix_bootloader =
-  (* Bootloaders that we know how to fix. *)
-  let can_fix_boot_loader =
+  (* Bootloaders that we know how to fix:
+   *  - first partition is NTFS, and
+   *  - first partition is bootable, and
+   *  - only one partition (ie. not Win Vista and later), and
+   *  - it's not already aligned to some small value (no point
+   *      moving it around unnecessarily)
+   *)
+  let rec can_fix_boot_loader () =
     match partitions with
-    | { p_type = ContentFS ("ntfs", _); p_bootable = true;
-        p_operation = OpCopy | OpIgnore | OpResize _ } :: _ -> true
+    | [ { p_part = { G.part_start = start };
+          p_type = ContentFS ("ntfs", _);
+          p_bootable = true;
+          p_operation = OpCopy | OpIgnore | OpResize _ } ]
+        when not_aligned_enough start -> true
     | _ -> false
+  and not_aligned_enough start =
+    let alignment = alignment_of start in
+    alignment < 12                      (* < 4K alignment *)
+  and alignment_of = function
+    | 0L -> 64
+    | n when n &^ 1L = 1L -> 0
+    | n -> 1 + alignment_of (n /^ 2L)
   in
 
-  match align_first, can_fix_boot_loader with
+  match align_first, can_fix_boot_loader () with
   | `Never, _
   | `Auto, false -> false
   | `Always, _
   | `Auto, true -> true
 
+let () =
+  if debug then
+    eprintf "align_first_partition_and_fix_bootloader = %b\n%!"
+      align_first_partition_and_fix_bootloader
+
 (* Repartition the target disk. *)
 
 (* Calculate the location of the partitions on the target disk.  This
@@ -1158,4 +1184,7 @@ let () =
     wrap "Resize operation completed with no errors.  Before deleting the old disk, carefully check that the resized disk boots and works correctly.\n";
   );
 
+  if debug_gc then
+    Gc.compact ();
+
   exit 0