File: resize.ml

package info (click to toggle)
libguestfs 1%3A1.44.0-2
  • links: PTS, VCS
  • area: main
  • in suites: bullseye
  • size: 118,932 kB
  • sloc: ansic: 458,017; ml: 51,424; sh: 13,191; java: 9,578; makefile: 7,931; cs: 6,328; haskell: 5,674; python: 3,871; perl: 3,528; erlang: 2,446; xml: 1,347; ruby: 350; pascal: 257; javascript: 157; lex: 135; yacc: 128; cpp: 10
file content (1446 lines) | stat: -rw-r--r-- 53,901 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
(* virt-resize
 * Copyright (C) 2010-2020 Red Hat Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this program; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

open Printf

open Std_utils
open Tools_utils
open Common_gettext.Gettext
open Unix_utils
open Getopt.OptionName

module G = Guestfs

(* Minimum surplus before we create an extra partition. *)
let min_extra_partition = 10L *^ 1024L *^ 1024L

(* Command line argument parsing. *)
type align_first_t = [ `Never | `Always | `Auto ]

(* Source partition type. *)
type parttype = MBR | GPT

(* Data structure describing the source disk's partition layout.
 *
 * NOTE: For MBR, only primary/extended partitions are tracked here.
 * Logical partitions are contained within an extended partition, and
 * we don't track them (they are just copied within the extended
 * partition).  For the same reason we cannot resize logical partitions.
 *)
type partition = {
  p_name : string;               (* Device name, like /dev/sda1. *)
  p_part : G.partition;          (* SOURCE partition data from libguestfs. *)
  p_bootable : bool;             (* Is it bootable? *)
  p_id : partition_id;           (* Partition (MBR/GPT) ID. *)
  p_type : partition_content;    (* Content type and content size. *)
  p_label : string option;       (* Label/name. *)
  p_guid : string option;        (* Partition GUID (GPT only). *)
  p_attributes : int64 option;   (* Partition attributes bit mask (GPT only). *)

  (* What we're going to do: *)
  mutable p_operation : partition_operation;
  p_target_partnum : int;        (* TARGET partition number. *)
  p_target_start : int64;        (* TARGET partition start (sector num). *)
  p_target_end : int64;          (* TARGET partition end (sector num). *)
}
and partition_content =
  | ContentUnknown               (* undetermined *)
  | ContentPV of int64           (* physical volume (size of PV) *)
  | ContentFS of string * int64  (* mountable filesystem (FS type, FS size) *)
  | ContentExtendedPartition     (* MBR extended partition *)
  | ContentSwap                  (* Swap partition *)
and partition_operation =
  | OpCopy                       (* copy it as-is, no resizing *)
  | OpIgnore                     (* ignore it (create on target, but don't
                                    copy any content) *)
  | OpDelete                     (* delete it *)
  | OpResize of int64            (* resize it to the new size *)
and partition_id =
  | No_ID                        (* No identifier. *)
  | MBR_ID of int                (* MBR ID. *)
  | GPT_Type of string           (* GPT UUID. *)

let rec debug_partition ?(sectsize=512L) p =
  printf "%s:\n" p.p_name;
  printf "\tpartition data: %ld %Ld-%Ld (%Ld bytes)\n"
    p.p_part.G.part_num p.p_part.G.part_start p.p_part.G.part_end
    p.p_part.G.part_size;
  printf "\tpartition sector data: %Ld-%Ld (%Ld sectors)\n"
    (p.p_part.G.part_start /^ sectsize) (p.p_part.G.part_end /^ sectsize)
    ((p.p_part.G.part_end +^ 1L -^ p.p_part.G.part_start) /^ sectsize);
  printf "\ttarget partition sector data: %Ld-%Ld (%Ld sectors)\n"
    p.p_target_start p.p_target_end (p.p_target_end +^ 1L -^ p.p_target_start);
  printf "\tbootable: %b\n" p.p_bootable;
  printf "\tpartition ID: %s\n"
    (match p.p_id with
    | No_ID -> "(none)"
    | MBR_ID i -> sprintf "0x%x" i
    | GPT_Type i -> i
    );
  printf "\tcontent: %s\n" (string_of_partition_content p.p_type);
  printf "\tlabel: %s\n"
    (match p.p_label with
    | Some label -> label
    | None -> "(none)"
    );
  printf "\tGUID: %s\n"
    (match p.p_guid with
    | Some guid -> guid
    | None -> "(none)"
    )
and string_of_partition_content = function
  | ContentUnknown -> "unknown data"
  | ContentPV sz -> sprintf "LVM PV (%Ld bytes)" sz
  | ContentFS (fs, sz) -> sprintf "filesystem %s (%Ld bytes)" fs sz
  | ContentExtendedPartition -> "extended partition"
  | ContentSwap -> "swap"
and string_of_partition_content_no_size = function
  | ContentUnknown -> "unknown data"
  | ContentPV _ -> "LVM PV"
  | ContentFS (fs, _) -> sprintf "filesystem %s" fs
  | ContentExtendedPartition -> "extended partition"
  | ContentSwap -> "swap"

(* Data structure describing LVs on the source disk.  This is only
 * used if the user gave the --lv-expand option.
 *)
type logvol = {
  lv_name : string;
  lv_type : logvol_content;
  mutable lv_operation : logvol_operation
}
(* ContentPV, ContentExtendedPartition cannot occur here *)
and logvol_content = partition_content
and logvol_operation =
  | LVOpNone                     (* nothing *)
  | LVOpExpand                   (* expand it *)

let debug_logvol lv =
  printf "%s:\n" lv.lv_name;
  printf "\tcontent: %s\n" (string_of_partition_content lv.lv_type)

type expand_content_method =
  | PVResize | Resize2fs | NTFSResize | BtrfsFilesystemResize | XFSGrowFS
  | Mkswap | ResizeF2fs

let string_of_expand_content_method = function
  | PVResize -> s_"pvresize"
  | Resize2fs -> s_"resize2fs"
  | NTFSResize -> s_"ntfsresize"
  | BtrfsFilesystemResize -> s_"btrfs-filesystem-resize"
  | XFSGrowFS -> s_"xfs_growfs"
  | Mkswap -> s_"mkswap"
  | ResizeF2fs -> s_"resize.f2fs"

type unknown_filesystems_mode =
  | UnknownFsIgnore
  | UnknownFsWarn
  | UnknownFsError

(* Main program. *)
let main () =
  let infile, outfile, align_first, alignment, copy_boot_loader,
    deletes,
    dryrun, expand, expand_content, extra_partition, format, ignores,
    lv_expands, ntfsresize_force, output_format,
    resizes, resizes_force, shrink, sparse, unknown_fs_mode =

    let add xs s = List.push_front s xs in

    let align_first = ref "auto" in
    let alignment = ref 128 in
    let copy_boot_loader = ref true in
    let deletes = ref [] in
    let dryrun = ref false in
    let expand = ref "" in
    let set_expand s =
      if s = "" then error (f_"empty --expand option")
      else if !expand <> "" then error (f_"--expand option given more than once")
      else expand := s
    in
    let expand_content = ref true in
    let extra_partition = ref true in
    let format = ref "" in
    let ignores = ref [] in
    let lv_expands = ref [] in
    let ntfsresize_force = ref false in
    let output_format = ref "" in
    let resizes = ref [] in
    let resizes_force = ref [] in
    let shrink = ref "" in
    let set_shrink s =
      if s = "" then error (f_"empty --shrink option")
      else if !shrink <> "" then error (f_"--shrink option given more than once")
      else shrink := s
    in
    let sparse = ref true in
    let unknown_fs_mode = ref "warn" in

    let argspec = [
      [ L"align-first" ], Getopt.Set_string (s_"never|always|auto", align_first), s_"Align first partition (default: auto)";
      [ L"alignment" ], Getopt.Set_int (s_"sectors", alignment),   s_"Set partition alignment (default: 128 sectors)";
      [ L"no-copy-boot-loader" ], Getopt.Clear copy_boot_loader, s_"Don’t copy boot loader";
      [ S 'd'; L"debug" ],        Getopt.Unit set_verbose,      s_"Enable debugging messages";
      [ L"delete" ],  Getopt.String (s_"part", add deletes),  s_"Delete partition";
      [ L"expand" ],  Getopt.String (s_"part", set_expand),     s_"Expand partition";
      [ L"no-expand-content" ], Getopt.Clear expand_content, s_"Don’t expand content";
      [ L"no-extra-partition" ], Getopt.Clear extra_partition, s_"Don’t create extra partition";
      [ L"format" ],  Getopt.Set_string (s_"format", format),     s_"Format of input disk";
      [ L"ignore" ],  Getopt.String (s_"part", add ignores),  s_"Ignore partition";
      [ L"lv-expand"; L"LV-expand"; L"lvexpand"; L"LVexpand" ], Getopt.String (s_"lv", add lv_expands), s_"Expand logical volume";
      [ S 'n'; L"dry-run"; L"dryrun" ],        Getopt.Set dryrun,            s_"Don’t perform changes";
      [ L"ntfsresize-force" ], Getopt.Set ntfsresize_force, s_"Force ntfsresize";
      [ L"output-format" ], Getopt.Set_string (s_"format", output_format), s_"Format of output disk";
      [ L"resize" ],  Getopt.String (s_"part=size", add resizes),  s_"Resize partition";
      [ L"resize-force" ], Getopt.String (s_"part=size", add resizes_force), s_"Forcefully resize partition";
      [ L"shrink" ],  Getopt.String (s_"part", set_shrink),     s_"Shrink partition";
      [ L"no-sparse" ], Getopt.Clear sparse,        s_"Turn off sparse copying";
      [ L"unknown-filesystems" ], Getopt.Set_string (s_"ignore|warn|error", unknown_fs_mode),
                                              s_"Behaviour on expand unknown filesystems (default: warn)";
    ] in
    let disks = ref [] in
    let anon_fun s = List.push_front s disks in
    let usage_msg =
      sprintf (f_"\
%s: resize a virtual machine disk

A short summary of the options is given below.  For detailed help please
read the man page virt-resize(1).
")
        prog in
    let opthandle = create_standard_options argspec ~anon_fun ~machine_readable:true usage_msg in
    Getopt.parse opthandle.getopt;

    if verbose () then (
      printf "command line:";
      List.iter (printf " %s") (Array.to_list Sys.argv);
      print_newline ()
    );

    (* Dereference the rest of the args. *)
    let alignment = !alignment in
    let copy_boot_loader = !copy_boot_loader in
    let deletes = List.rev !deletes in
    let dryrun = !dryrun in
    let expand = match !expand with "" -> None | str -> Some str in
    let expand_content = !expand_content in
    let extra_partition = !extra_partition in
    let format = match !format with "" -> None | str -> Some str in
    let ignores = List.rev !ignores in
    let lv_expands = List.rev !lv_expands in
    let ntfsresize_force = !ntfsresize_force in
    let output_format = match !output_format with "" -> None | str -> Some str in
    let resizes = List.rev !resizes in
    let resizes_force = List.rev !resizes_force in
    let shrink = match !shrink with "" -> None | str -> Some str in
    let sparse = !sparse in
    let unknown_fs_mode = !unknown_fs_mode in

    if alignment < 1 then
      error (f_"alignment cannot be < 1");
    let alignment = Int64.of_int alignment in

    let align_first =
      match !align_first with
      | "never" -> `Never
      | "always" -> `Always
      | "auto" -> `Auto
      | _ ->
        error (f_"unknown --align-first option: use never|always|auto") in

    let unknown_fs_mode =
      match unknown_fs_mode with
      | "ignore" -> UnknownFsIgnore
      | "warn" -> UnknownFsWarn
      | "error" -> UnknownFsError
      | _ ->
        error (f_"unknown --unknown-filesystems: use ignore|warn|error") in

    (* No arguments and machine-readable mode?  Print out some facts
     * about what this binary supports.  We only need to print out new
     * things added since this option, or things which depend on features
     * of the appliance.
     *)
    (match !disks, machine_readable () with
    | [], Some { pr } ->
      pr "virt-resize\n";
      pr "ntfsresize-force\n";
      pr "32bitok\n";
      pr "128-sector-alignment\n";
      pr "alignment\n";
      pr "align-first\n";
      pr "infile-uri\n";
      let g = open_guestfs () in
      g#add_drive "/dev/null";
      g#launch ();
      if g#feature_available [| "ntfsprogs"; "ntfs3g" |] then
        pr "ntfs\n";
      if g#feature_available [| "btrfs" |] then
        pr "btrfs\n";
      if g#feature_available [| "xfs" |] then
        pr "xfs\n";
      if g#feature_available [| "f2fs" |] then
        pr "f2fs\n";
      exit 0
    | _, _ -> ()
    );

    (* Verify we got exactly 2 disks. *)
    let infile, outfile =
      match List.rev !disks with
      | [infile; outfile] -> infile, outfile
      | _ ->
        error (f_"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 infile = outfile then
      error (f_"you cannot use the same disk image for input and output");

    (* infile can be a URI. *)
    let infile =
      try (infile, URI.parse_uri infile)
      with URI.Parse_failed ->
        error (f_"error parsing URI ‘%s’. Look for error messages printed above.")
          infile in

    (* outfile can be a URI. *)
    let outfile =
      try (outfile, URI.parse_uri outfile)
      with URI.Parse_failed ->
        error (f_"error parsing URI ‘%s’. Look for error messages printed above.")
          outfile in

    infile, outfile, align_first, alignment, copy_boot_loader,
    deletes,
    dryrun, expand, expand_content, extra_partition, format, ignores,
    lv_expands, ntfsresize_force, output_format,
    resizes, resizes_force, shrink, sparse, unknown_fs_mode in

  (* Default to true, since NTFS/btrfs/XFS/f2fs support are usually available. *)
  let ntfs_available = ref true in
  let btrfs_available = ref true in
  let xfs_available = ref true in
  let f2fs_available = ref true in

  (* Add a drive to an handle using the elements of the URI,
   * and few additional parameters.
   *)
  let add_drive_uri (g : Guestfs.guestfs) ?format ?readonly ?cachemode
                    { URI.path; protocol; server; username; password } =
    g#add_drive ?format ?readonly ?cachemode
      ~protocol ?server ?username ?secret:password path
  in

  (* Add in and out disks to the handle and launch. *)
  let connect_both_disks () =
    let g = open_guestfs () in
    add_drive_uri g ?format ~readonly:true (snd infile);
    (* The output disk is being created, so use cache=unsafe here. *)
    add_drive_uri g ?format:output_format ~readonly:false ~cachemode:"unsafe"
      (snd outfile);
    if not (quiet ()) then (
      let machine_readable = machine_readable () <> None in
      Progress.set_up_progress_bar ~machine_readable g
    );
    g#launch ();

    (* Set the filter to /dev/sda, in case there are any rogue
     * PVs lying around on the target disk.
     *)
    g#lvm_set_filter [|"/dev/sda"|];

    (* Update features available in the daemon. *)
    ntfs_available := g#feature_available [|"ntfsprogs"; "ntfs3g"|];
    btrfs_available := g#feature_available [|"btrfs"|];
    xfs_available := g#feature_available [|"xfs"|];
    f2fs_available := g#feature_available [|"f2fs"|];

    g
  in

  let g =
    message (f_"Examining %s") (fst infile);
    let g = connect_both_disks () in
    g in

  (* Get the size in bytes of each disk.
   *
   * Originally we computed this by looking at the same of the host file,
   * but of course this failed for qcow2 images (RHBZ#633096).  The right
   * way to do it is with g#blockdev_getsize64.
   *)
  let sectsize, insize, outsize =
    let sectsize = Int64.of_int (g#blockdev_getss "/dev/sdb") in
    let insize = g#blockdev_getsize64 "/dev/sda" in
    let outsize = g#blockdev_getsize64 "/dev/sdb" in
    debug "%s size %Ld bytes" (fst infile) insize;
    debug "%s size %Ld bytes" (fst outfile) outsize;
    sectsize, insize, outsize in

  let max_bootloader =
    (* In reality the number of sectors containing boot loader data will be
     * less than this (although Windows 7 defaults to putting the first
     * partition on sector 2048, and has quite a large boot loader).
     *
     * However make this large enough to be sure that we have copied over
     * the boot loader.  We could also do this by looking for the sector
     * offset of the first partition.
     *
     * It doesn't matter if we copy too much.
     *)
    4096 * 512 in

  (* Check the disks are at least as big as the bootloader. *)
  if insize < Int64.of_int max_bootloader then
    error (f_"%s: file is too small to be a disk image (%Ld bytes)")
      (fst infile) insize;
  if outsize < Int64.of_int max_bootloader then
    error (f_"%s: file is too small to be a disk image (%Ld bytes)")
      (fst outfile) outsize;

  (* Get the source partition type. *)
  let parttype, parttype_string =
    let pt = g#part_get_parttype "/dev/sda" in
    debug "partition table type: %s" pt;

    match pt with
    | "msdos" -> MBR, "msdos"
    | "gpt" -> GPT, "gpt"
    | _ ->
      error (f_"%s: unknown partition table type\nvirt-resize only supports MBR (DOS) and GPT partition tables.")
        (fst infile) in

  let disk_guid =
    match parttype with
    | MBR -> None
    | GPT ->
      try Some (g#part_get_disk_guid "/dev/sda")
      with G.Error _ -> None in

  (* Build a data structure describing the source disk's partition layout. *)
  let get_partition_content =
    let pvs_full = Array.to_list (g#pvs_full ()) in
    fun dev ->
      try
        let fs = g#vfs_type dev in
        if fs = "unknown" then
          ContentUnknown
        else if fs = "swap" then
          ContentSwap
        else if fs = "LVM2_member" then (
          let rec loop = function
            | [] ->
              error (f_"%s: physical volume not returned by pvs_full") dev
            | pv :: _ when g#canonical_device_name pv.G.pv_name = dev ->
              ContentPV pv.G.pv_size
            | _ :: pvs -> loop pvs
          in
          loop pvs_full
        )
        else (
          g#mount_ro dev "/";
          let stat = g#statvfs "/" in
          g#umount "/";
          let size = stat.G.bsize *^ stat.G.blocks in
          ContentFS (fs, size)
        )
      with
        G.Error _ -> ContentUnknown
  in

  let is_extended_partition = function
    | MBR_ID (0x05|0x0f) -> true
    | MBR_ID _ | GPT_Type _ | No_ID -> false
  in

  let partitions : partition list =
    let parts = Array.to_list (g#part_list "/dev/sda") in

    if List.length parts = 0 then
      error (f_"the source disk has no partitions");

    (* Filter out logical partitions.  See note above. *)
    let parts =
        List.filter (fun p -> parttype <> MBR || p.G.part_num <= 4_l)
        parts in

    let partitions =
      List.map (
        fun ({ G.part_num } as part) ->
          let part_num = Int32.to_int part_num in
          let name = sprintf "/dev/sda%d" part_num in
          let bootable = g#part_get_bootable "/dev/sda" part_num in
          let id =
            match parttype with
            | GPT ->
              (try GPT_Type (g#part_get_gpt_type "/dev/sda" part_num)
              with G.Error _ -> No_ID)
            | MBR ->
              (try MBR_ID (g#part_get_mbr_id "/dev/sda" part_num)
              with G.Error _ -> No_ID) in
          let typ =
            if is_extended_partition id then ContentExtendedPartition
            else get_partition_content name in
          let label =
            try Some (g#part_get_name "/dev/sda" part_num)
            with G.Error _ -> None in
          let attributes =
            match parttype with
            | MBR -> None
            | GPT ->
              try Some (g#part_get_gpt_attributes "/dev/sda" part_num)
              with G.Error _ -> None in
          let guid =
            match parttype with
            | MBR -> None
            | GPT ->
              try Some (g#part_get_gpt_guid "/dev/sda" part_num)
              with G.Error _ -> None in

          { p_name = name; p_part = part;
            p_bootable = bootable; p_id = id; p_type = typ;
            p_label = label; p_guid = guid; p_attributes = attributes;
            p_operation = OpCopy; p_target_partnum = 0;
            p_target_start = 0L; p_target_end = 0L }
      ) parts in

    if verbose () then (
      eprintf "%d partitions found\n" (List.length partitions);
      List.iter debug_partition partitions
    );

    (* Check content isn't larger than partitions.  If it is then
     * something has gone wrong and we shouldn't continue.  Old
     * virt-resize didn't do these checks.
     *)
    List.iter (
      function
      | { p_name = name; p_part = { G.part_size = size };
          p_type = ContentPV pv_size }
          when size < pv_size ->
        error (f_"%s: partition size %Ld < physical volume size %Ld")
          name size pv_size
      | { p_name = name; p_part = { G.part_size = size };
          p_type = ContentFS (_, fs_size) }
          when size < fs_size ->
        error (f_"%s: partition size %Ld < filesystem size %Ld")
          name size fs_size
      | _ -> ()
    ) partitions;

    (* Check partitions don't overlap. *)
    let rec loop end_of_prev = function
      | [] -> ()
      | { p_name = name; p_part = { G.part_start } } :: _
          when end_of_prev > part_start ->
        error (f_"%s: this partition overlaps the previous one") name
      | { p_part = { G.part_end } } :: parts -> loop part_end parts
    in
    loop 0L partitions;

    partitions in

  (* Build a data structure describing LVs on the source disk. *)
  let lvs =
    let lvs = Array.to_list (g#lvs ()) in

    let lvs = List.map (
      fun name ->
        let typ = get_partition_content name in
        assert (
          match typ with
          | ContentPV _ | ContentExtendedPartition -> false
          | ContentUnknown | ContentFS _ | ContentSwap -> true
        );

        { lv_name = name; lv_type = typ; lv_operation = LVOpNone }
    ) lvs in

    if verbose () then (
      printf "%d logical volumes found\n" (List.length lvs);
      List.iter debug_logvol lvs
    );

    lvs in

  (* These functions tell us if we know how to expand the content of
   * a particular partition or LV, and what method to use.
   *)
  let can_expand_content =
    if expand_content then
      function
      | ContentUnknown -> false
      | ContentPV _ -> true
      | ContentFS (("ext2"|"ext3"|"ext4"), _) -> true
      | ContentFS (("ntfs"), _) when !ntfs_available -> true
      | ContentFS (("btrfs"), _) when !btrfs_available -> true
      | ContentFS (("xfs"), _) when !xfs_available -> true
      | ContentFS (("f2fs"), _) when !f2fs_available -> true
      | ContentFS _ -> false
      | ContentExtendedPartition -> false
      | ContentSwap -> true
    else
      fun _ -> false

  and expand_content_method =
    if expand_content then
      function
      | ContentUnknown -> assert false
      | ContentPV _ -> PVResize
      | ContentFS (("ext2"|"ext3"|"ext4"), _) -> Resize2fs
      | ContentFS (("ntfs"), _) when !ntfs_available -> NTFSResize
      | ContentFS (("btrfs"), _) when !btrfs_available -> BtrfsFilesystemResize
      | ContentFS (("xfs"), _) when !xfs_available -> XFSGrowFS
      | ContentFS (("f2fs"), _) when !f2fs_available -> ResizeF2fs
      | ContentFS _ -> assert false
      | ContentExtendedPartition -> assert false
      | ContentSwap -> Mkswap
    else
      fun _ -> assert false
  in

  (* Helper function to locate a partition given what the user might
   * type on the command line.  It also gives errors for partitions
   * that the user has asked to be ignored or deleted.
   *)
  let find_partition =
    let hash = Hashtbl.create 13 in
    List.iter (fun ({ p_name = name } as p) -> Hashtbl.add hash name p)
      partitions;
    fun ~option name ->
      let name =
        if String.length name < 5 || String.sub name 0 5 <> "/dev/" then
          "/dev/" ^ name
        else
          name in
      let name = g#canonical_device_name name in

      let partition =
        try Hashtbl.find hash name
        with Not_found ->
          error (f_"%s: partition not found in the source disk image (this error came from ‘%s’ option on the command line).  Try running this command: virt-filesystems --partitions --long -a %s")
          name option (fst infile) in

      if partition.p_operation = OpIgnore then
        error (f_"%s: partition already ignored, you cannot use it in ‘%s’ option")
          name option;

      if partition.p_operation = OpDelete then
        error (f_"%s: partition already deleted, you cannot use it in ‘%s’ option")
          name option;

      partition in

  (* Handle --ignore option. *)
  List.iter (
    fun dev ->
      let p = find_partition ~option:"--ignore" dev in
      p.p_operation <- OpIgnore
  ) ignores;

  (* Handle --delete option. *)
  List.iter (
    fun dev ->
      let p = find_partition ~option:"--delete" dev in
      p.p_operation <- OpDelete
  ) deletes;

  (* Helper function to mark a partition for resizing.  It prevents the
   * user from trying to mark the same partition twice.  If the force
   * flag is given, then we will allow the user to shrink the partition
   * even if we think that would destroy the content.
   *)
  let mark_partition_for_resize ~option ?(force = false) p newsize =
    let name = p.p_name in
    let oldsize = p.p_part.G.part_size in

    (match p.p_operation with
    | OpResize _ ->
      error (f_"%s: this partition has already been marked for resizing")
        name
    | OpIgnore | OpDelete ->
       (* This error should have been caught already by find_partition ... *)
      error (f_"%s: this partition has already been ignored or deleted")
        name
    | OpCopy -> ()
    );

    (* Only do something if the size will change. *)
    if oldsize <> newsize then (
      let bigger = newsize > oldsize in

      if not bigger && not force then (
        (* Check if this contains filesystem content, and how big that is
         * and whether we will destroy any content by shrinking this.
         *)
        match p.p_type with
        | ContentUnknown ->
          error (f_"%s: This partition has unknown content which might be damaged by shrinking it.  If you want to shrink this partition, you need to use the ‘--resize-force’ option, but that could destroy any data on this partition.  (This error came from ‘%s’ option on the command line.)")
            name option
        | ContentPV size when size > newsize ->
          error (f_"%s: This partition contains an LVM physical volume which will be damaged by shrinking it below %Ld bytes (user asked to shrink it to %Ld bytes).  If you want to shrink this partition, you need to use the ‘--resize-force’ option, but that could destroy any data on this partition.  (This error came from ‘%s‘ option on the command line.)")
            name size newsize option
        | ContentPV _ -> ()
        | ContentFS (fstype, size) when size > newsize ->
          error (f_"%s: This partition contains a %s filesystem which will be damaged by shrinking it below %Ld bytes (user asked to shrink it to %Ld bytes).  If you want to shrink this partition, you need to use the ‘--resize-force’ option, but that could destroy any data on this partition.  (This error came from ‘%s’ option on the command line.)")
            name fstype size newsize option
        | ContentFS _ -> ()
        | ContentExtendedPartition ->
          error (f_"%s: This extended partition contains logical partitions which might be damaged by shrinking it.  If you want to shrink this partition, you need to use the ‘--resize-force’ option, but that could destroy logical partitions within this partition.  (This error came from ‘%s’ option on the command line.)")
            name option
        | ContentSwap -> ()
      );

      p.p_operation <- OpResize newsize
    )
  in

  (* Handle --resize and --resize-force options. *)
  let do_resize ~option ?(force = false) arg =
    (* Argument is "dev=size". *)
    let dev, sizefield =
      try
        let i = String.index arg '=' in
        let n = String.length arg - (i+1) in
        if n == 0 then raise Not_found;
        String.sub arg 0 i, String.sub arg (i+1) n
      with Not_found ->
        error (f_"%s: missing size field in ‘%s’ option") arg option in

    let p = find_partition ~option dev in

    (* Parse the size field. *)
    let oldsize = p.p_part.G.part_size in
    let newsize = parse_resize oldsize sizefield in

    if newsize <= 0L then
      error (f_"%s: new partition size is zero or negative") dev;

    mark_partition_for_resize ~option ~force p newsize
  in

  List.iter (do_resize ~option:"--resize") resizes;
  List.iter (do_resize ~option:"--resize-force" ~force:true) resizes_force;

  (* Helper function calculates the surplus space, given the total
   * required so far for the current partition layout, compared to
   * the size of the target disk.  If the return value >= 0 then it's
   * a surplus, if it is < 0 then it's a deficit.
   *)
  let calculate_surplus () =
    (* We need some overhead for partitioning. *)
    let overhead =
      let maxl64 = List.fold_left max 0L in

      let nr_partitions = List.length partitions in

      let gpt_start_sects = 64L in
      let gpt_end_sects = gpt_start_sects in

      let first_part_start_sects =
        match partitions with
        | { p_part = { G.part_start = start }} :: _ ->
          start /^ sectsize
        | [] -> 0L in

      let max_bootloader_sects = Int64.of_int max_bootloader /^ 512L in

      (* Size of the unpartitioned space before the first partition. *)
      let start_overhead_sects =
        maxl64 [gpt_start_sects; max_bootloader_sects; first_part_start_sects] in

      (* Maximum space lost because of alignment of partitions. *)
      let alignment_sects = alignment *^ Int64.of_int (nr_partitions + 1) in

      (* Add up the total max. overhead. *)
      let overhead_sects =
        start_overhead_sects +^ alignment_sects +^ gpt_end_sects in
      sectsize *^ overhead_sects in

    let required = List.fold_left (
      fun total p ->
        let newsize =
          match p.p_operation with
          | OpCopy | OpIgnore -> p.p_part.G.part_size
          | OpDelete -> 0L
          | OpResize newsize -> newsize in
        total +^ newsize
    ) 0L partitions in

    let surplus = outsize -^ (required +^ overhead) in

    debug "calculate surplus: outsize=%Ld required=%Ld overhead=%Ld surplus=%Ld"
          outsize required overhead surplus;

    surplus
  in

  (* Handle --expand and --shrink options. *)
  if expand <> None && shrink <> None then
    error (f_"you cannot use options --expand and --shrink together");

  if expand <> None || shrink <> None then (
    let surplus = calculate_surplus () in

    debug "surplus before --expand or --shrink: %Ld" surplus;

    (match expand with
     | None -> ()
     | Some dev ->
         if surplus < 0L then
           error (f_"You cannot use --expand when there is no surplus space to expand into.  You need to make the target disk larger by at least %s.")
             (human_size (Int64.neg surplus));

         let option = "--expand" in
         let p = find_partition ~option dev in
         let oldsize = p.p_part.G.part_size in
         mark_partition_for_resize ~option p (oldsize +^ surplus)
    );
    (match shrink with
     | None -> ()
     | Some dev ->
         if surplus > 0L then
           error (f_"You cannot use --shrink when there is no deficit (see ‘deficit’ in the virt-resize(1) man page).");

         let option = "--shrink" in
         let p = find_partition ~option dev in
         let oldsize = p.p_part.G.part_size in
         mark_partition_for_resize ~option p (oldsize +^ surplus)
    )
  );

  (* Calculate the final surplus.
   * At this point, this number must be >= 0.
   *)
  let surplus =
    let surplus = calculate_surplus () in

    if surplus < 0L then (
      let deficit = Int64.neg surplus in
      error (f_"There is a deficit of %Ld bytes (%s).  You need to make the target disk larger by at least this amount or adjust your resizing requests.")
      deficit (human_size deficit)
    );

    surplus in

  (* Mark the --lv-expand LVs. *)
  let hash = Hashtbl.create 13 in
  List.iter (fun ({ lv_name = name } as lv) -> Hashtbl.add hash name lv) lvs;

  List.iter (
    fun name ->
      let lv =
        try Hashtbl.find hash name
        with Not_found ->
          error (f_"%s: logical volume not found in the source disk image (this error came from ‘--lv-expand’ option on the command line).  Try running this command: virt-filesystems --logical-volumes --long -a %s")
            name (fst infile) in
      lv.lv_operation <- LVOpExpand
  ) lv_expands;

  (* In case we need to error out on unknown/unhandled filesystems,
   * iterate on what we need to resize/expand.
   *)
  (match unknown_fs_mode with
  | UnknownFsIgnore -> ()
  | UnknownFsWarn -> ()
  | UnknownFsError ->
    List.iter (
      fun p ->
        match p.p_operation with
        | OpCopy
        | OpIgnore
        | OpDelete -> ()
        | OpResize _ ->
          if not (can_expand_content p.p_type) then (
            (match p.p_type with
            | ContentUnknown
            | ContentPV _
            | ContentExtendedPartition
            | ContentSwap -> ()
            | ContentFS (fs, _) ->
              error (f_"unknown/unavailable method for expanding the %s filesystem on %s")
                fs p.p_name
            );
          )
    ) partitions;

    List.iter (
      fun lv ->
        match lv.lv_operation with
        | LVOpNone -> ()
        | LVOpExpand ->
          if not (can_expand_content lv.lv_type) then (
            (match lv.lv_type with
            | ContentUnknown
            | ContentPV _
            | ContentExtendedPartition
            | ContentSwap -> ()
            | ContentFS (fs, _) ->
              error (f_"unknown/unavailable method for expanding the %s filesystem on %s")
                fs lv.lv_name;
            );
          )
    ) lvs;
  );

  (* Print a summary of what we will do. *)
  flush stderr;

  if not (quiet ()) then (
    printf "**********\n\n";
    printf "Summary of changes:\n\n";

    let rec print_summary p =
      let text =
        match p.p_operation with
        | OpCopy ->
          sprintf (f_"%s: This partition will be left alone.") p.p_name
        | OpIgnore ->
          sprintf (f_"%s: This partition will be created, but the contents will be ignored (ie. not copied to the target).") p.p_name
        | OpDelete ->
          sprintf (f_"%s: This partition will be deleted.") p.p_name
        | OpResize newsize ->
          sprintf (f_"%s: This partition will be resized from %s to %s.")
            p.p_name (human_size p.p_part.G.part_size) (human_size newsize) ^
            if can_expand_content p.p_type then (
              sprintf (f_"  The %s on %s will be expanded using the ‘%s’ method.")
                (string_of_partition_content_no_size p.p_type)
                p.p_name
                (string_of_expand_content_method
                   (expand_content_method p.p_type))
            ) else (
              (match p.p_type with
              | ContentUnknown
              | ContentPV _
              | ContentExtendedPartition
              | ContentSwap -> ()
              | ContentFS (fs, _) ->
                warning (f_"unknown/unavailable method for expanding the %s filesystem on %s")
                  fs p.p_name;
              );
              ""
            ) in

      wrap (text ^ "\n\n") in

    List.iter print_summary partitions;

    List.iter (
      fun ({ lv_name = name } as lv) ->
        match lv.lv_operation with
        | LVOpNone -> ()
        | LVOpExpand ->
            let text =
              sprintf (f_"%s: This logical volume will be expanded to maximum size.")
                name ^
              if can_expand_content lv.lv_type then (
                sprintf (f_"  The %s on %s will be expanded using the ‘%s’ method.")
                  (string_of_partition_content_no_size lv.lv_type)
                  name
                  (string_of_expand_content_method
                     (expand_content_method lv.lv_type))
              ) else (
                (match lv.lv_type with
                | ContentUnknown
                | ContentPV _
                | ContentExtendedPartition
                | ContentSwap -> ()
                | ContentFS (fs, _) ->
                  warning (f_"unknown/unavailable method for expanding the %s filesystem on %s")
                    fs name;
                );
                ""
              ) in

            wrap (text ^ "\n\n")
    ) lvs;

    if surplus > 0L then (
      let text =
        sprintf (f_"There is a surplus of %s.") (human_size surplus) ^
        if extra_partition then (
          if surplus >= min_extra_partition then
            s_"  An extra partition will be created for the surplus."
          else
            s_"  The surplus space is not large enough for an extra partition to be created and so it will just be ignored."
        ) else
          s_"  The surplus space will be ignored.  Run a partitioning program in the guest to partition this extra space if you want." in

      wrap (text ^ "\n\n")
    );

    printf "**********\n";
    flush stdout
  );

  if dryrun then exit 0;

  (* Create a partition table.
   *
   * We *must* do this before copying the bootloader across, and copying
   * the bootloader must be careful not to disturb this partition table
   * (RHBZ#633766).  There are two reasons for this:
   *
   * (1) The 'parted' library is stupid and broken.  In many ways.  In
   * this particular instance the stupid and broken bit is that it
   * overwrites the whole boot sector when initializating a partition
   * table.  (Upstream don't consider this obvious problem to be a bug).
   *
   * (2) GPT has a backup partition table located at the end of the disk.
   * It's non-movable, because the primary GPT contains fixed references
   * to both the size of the disk and the backup partition table at the
   * end.  This would be a problem for any resize that didn't either
   * carefully move the backup GPT (and rewrite those references) or
   * recreate the whole partition table from scratch.
   *)
  let g =
    (* Try hard to initialize the partition table.  This might involve
     * relaunching another handle.
     *)
    message (f_"Setting up initial partition table on %s") (fst outfile);

    let last_error = ref "" in
    let rec initialize_partition_table g attempts =
      let ok =
        try
          g#part_init "/dev/sdb" parttype_string;
          Option.may (g#part_set_disk_guid "/dev/sdb") disk_guid;
          true
        with G.Error error -> last_error := error; false in
      if ok then g, true
      else if attempts > 0 then (
        g#zero "/dev/sdb";
        g#shutdown ();
        g#close ();

        let g = connect_both_disks () in
        initialize_partition_table g (attempts-1)
      )
      else g, false
    in

    let g, ok = initialize_partition_table g 5 in
    if not ok then
      error (f_"Failed to initialize the partition table on the target disk.  You need to wipe or recreate the target disk and then run virt-resize again.\n\nThe underlying error was: %s") !last_error;

    g in

  (* Copy the bootloader across.
   * Don't disturb the partition table that we just wrote.
   * https://secure.wikimedia.org/wikipedia/en/wiki/Master_Boot_Record
   * https://secure.wikimedia.org/wikipedia/en/wiki/GUID_Partition_Table
   *)
  if copy_boot_loader then (
    let bootsect = g#pread_device "/dev/sda" 446 0L in
    if String.length bootsect < 446 then
      error (f_"pread-device: short read");
    ignore (g#pwrite_device "/dev/sdb" bootsect 0L);

    let start =
      if parttype <> GPT then 512L
      else
        (* With 512 byte sectors, GPT looks like:
         *    512 bytes   sector 0       protective MBR
         *   1024 bytes   sector 1       GPT header
         *  17408 bytes   sectors 2-33   GPT entries (up to 128 x 128 bytes)
         *
         * With 4K sectors, GPT puts more entries in each sector, so
         * the partition table looks like this:
         *   4096 bytes   sector 0       protective MBR
         *   8192 bytes   sector 1       GPT header
         *  24576 bytes   sectors 2-5    GPT entries (up to 128 x 128 bytes)
         *
         * qemu doesn't support 4k sectors yet, so let's just use the
         * 512 sector number for now.
         *)
        17408L in

    let loader = g#pread_device "/dev/sda" max_bootloader start in
    if String.length loader < max_bootloader then
      error (f_"pread-device: short read");
    ignore (g#pwrite_device "/dev/sdb" loader start)
  );

  (* 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:
     *  - 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_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
    | `Never, _
    | `Auto, false -> false
    | `Always, _
    | `Auto, true -> true in

  debug "align_first_partition_and_fix_bootloader = %b"
        align_first_partition_and_fix_bootloader;

  (* Repartition the target disk. *)

  (* Calculate the location of the partitions on the target disk.  This
   * also removes from the list any partitions that will be deleted, so
   * the final list just contains partitions that need to be created
   * on the target.
   *)
  let partitions =
    let rec loop partnum start = function
    | p :: ps ->
      (match p.p_operation with
      | OpDelete -> loop partnum start ps (* skip p *)

      | OpIgnore | OpCopy ->          (* same size *)
        (* Size in sectors. *)
        let size = div_roundup64 p.p_part.G.part_size sectsize in
        (* Start of next partition + alignment. *)
        let end_ = start +^ size in
        let next = roundup64 end_ alignment in

        debug "target partition %d: ignore or copy: start=%Ld end=%Ld"
              partnum start (end_ -^ 1L);

        { p with p_target_start = start; p_target_end = end_ -^ 1L;
          p_target_partnum = partnum } :: loop (partnum+1) next ps

      | OpResize newsize ->           (* resized partition *)
        (* New size in sectors. *)
        let size = div_roundup64 newsize sectsize in
        (* Start of next partition + alignment. *)
        let next = start +^ size in
        let next = roundup64 next alignment in

        debug "target partition %d: resize: newsize=%Ld start=%Ld end=%Ld"
              partnum newsize start (next -^ 1L);

        { p with p_target_start = start; p_target_end = next -^ 1L;
          p_target_partnum = partnum } :: loop (partnum+1) next ps
      )

    | [] ->
      (* Create the surplus partition if there is room for it. *)
      if extra_partition && surplus >= min_extra_partition then (
        [ {
          (* Since this partition has no source, this data is
           * meaningless and not used since the operation is
           * OpIgnore.
           *)
          p_name = "";
          p_part = { G.part_num = 0l; part_start = 0L; part_end = 0L;
                     part_size = 0L };
          p_bootable = false; p_id = No_ID; p_type = ContentUnknown;
          p_label = None; p_guid = None;
          p_attributes = None;

          (* Target information is meaningful. *)
          p_operation = OpIgnore;
          p_target_partnum = partnum;
          p_target_start = start; p_target_end = ~^ 64L
        } ]
      )
      else
        [] in

    (* Choose the alignment of the first partition based on the
     * '--align-first' option.  Old virt-resize used to always align this
     * to 64 sectors, but this causes boot failures unless we are able to
     * adjust the bootloader accordingly.
     *)
    let start =
      if align_first_partition_and_fix_bootloader then
        alignment
      else
        (* Preserve the existing start, but convert to sectors. *)
        (List.hd partitions).p_part.G.part_start /^ sectsize in

    loop 1 start partitions in

  if verbose () then (
    printf "After calculate target partitions:\n";
    List.iter (debug_partition ~sectsize) partitions
  );

  (* Now partition the target disk. *)
  List.iter (
    fun p ->
      g#part_add "/dev/sdb" "primary" p.p_target_start p.p_target_end
  ) partitions;

  (* Set bootable and MBR IDs.  Do this *before* copying over the data,
   * because the rewritten sfdisk "helpfully" overwrites the partition
   * table in the first sector of an extended partition if a partition
   * is changed from primary to extended.  Thus we need to set the
   * MBR ID before doing the copy so sfdisk doesn't corrupt things.
   *)
  let set_partition_attributes p =
      if p.p_bootable then
        g#part_set_bootable "/dev/sdb" p.p_target_partnum true;

      Option.may (g#part_set_name "/dev/sdb" p.p_target_partnum) p.p_label;
      Option.may (g#part_set_gpt_guid "/dev/sdb" p.p_target_partnum) p.p_guid;
      Option.may (g#part_set_gpt_attributes "/dev/sdb" p.p_target_partnum) p.p_attributes;

      match parttype, p.p_id with
      | GPT, GPT_Type gpt_type ->
        g#part_set_gpt_type "/dev/sdb" p.p_target_partnum gpt_type
      | MBR, MBR_ID mbr_id ->
        g#part_set_mbr_id "/dev/sdb" p.p_target_partnum mbr_id
      | GPT, (No_ID|MBR_ID _) | MBR, (No_ID|GPT_Type _) -> ()
  in
  List.iter set_partition_attributes partitions;

  (* Copy over the data. *)
  let copy_partition p =
      match p.p_operation with
      | OpCopy | OpResize _ ->
        (* XXX Old code had 'when target_partnum > 0', but it appears
         * to have served no purpose since the field could never be 0
         * at this point.
         *)

        let oldsize = p.p_part.G.part_size in
        let newsize =
          match p.p_operation with OpResize s -> s | _ -> oldsize in

        let copysize = if newsize < oldsize then newsize else oldsize in

        let source = p.p_name in
        let target = sprintf "/dev/sdb%d" p.p_target_partnum in

        message (f_"Copying %s") source;

        (match p.p_type with
         | ContentUnknown | ContentPV _ | ContentFS _ | ContentSwap ->
           g#copy_device_to_device ~size:copysize ~sparse source target

         | ContentExtendedPartition ->
           (* You can't just copy an extended partition by name, eg.
            * source = "/dev/sda2", because the device name only covers
            * the first 1K of the partition.  Instead, copy the
            * source bytes from the parent disk (/dev/sda).
            *
            * You can't write directly to the extended partition,
            * because the size of it reported by Linux is always 1024
            * bytes. Instead, write to the offset of the extended
            * partition in the destination disk (/dev/sdb).
            *)
           let srcoffset = p.p_part.G.part_start in
           let destoffset = p.p_target_start *^ 512L in
           g#copy_device_to_device ~srcoffset ~destoffset ~size:copysize
                                   ~sparse
                                   "/dev/sda" "/dev/sdb"
        )
      | OpIgnore | OpDelete -> ()
  in
  List.iter copy_partition partitions;

  (* Fix the bootloader if we aligned the first partition. *)
  if align_first_partition_and_fix_bootloader then (
    (* See can_fix_boot_loader above. *)
    match partitions with
    | { p_type = ContentFS ("ntfs", _); p_bootable = true;
        p_target_partnum = partnum; p_target_start = start } :: _ ->
      (* If the first partition is NTFS and bootable, set the "Number of
       * Hidden Sectors" field in the NTFS Boot Record so that the
       * filesystem is still bootable.
       *)

      (* Should always be /dev/sdb1? *)
      let target = sprintf "/dev/sdb%d" partnum in

      (* Sanity check: it contains the NTFS magic. *)
      let magic = g#pread_device target 8 3L in
      if magic <> "NTFS    " then
        warning (f_"first partition is NTFS but does not contain NTFS boot loader magic")
      else (
        message (f_"Fixing first NTFS partition boot record");

        if verbose () then (
          let old_hidden = int_of_le32 (g#pread_device target 4 0x1c_L) in
          debug "old hidden sectors value: 0x%Lx" old_hidden
        );

        let new_hidden = le32_of_int start in
        ignore (g#pwrite_device target new_hidden 0x1c_L)
      )

    | { p_type =
        (ContentFS _|ContentUnknown|ContentPV _
            |ContentExtendedPartition|ContentSwap) } :: _
    | [] -> ()
  );

  (* After copying the data over we must shut down and restart the
   * appliance in order to expand the content.  The reason for this may
   * not be obvious, but it's because otherwise we'll have duplicate VGs
   * (the old VG(s) and the new VG(s)) which breaks LVM.
   *
   * The restart is only required if we're going to expand something.
   *)
  let to_be_expanded =
    List.exists (
      function
      | ({ p_operation = OpResize _ } as p) ->
        can_expand_content p.p_type
      | { p_operation = (OpCopy | OpIgnore | OpDelete) } -> false
    ) partitions
    || List.exists (
      function
      | ({ lv_operation = LVOpExpand } as lv) ->
        can_expand_content lv.lv_type
      | { lv_operation = LVOpNone } -> false
    ) lvs in

  let g =
    if to_be_expanded then (
      g#shutdown ();
      g#close ();

      let g = open_guestfs () in
      (* The output disk is being created, so use cache=unsafe here. *)
      add_drive_uri g ?format:output_format ~readonly:false ~cachemode:"unsafe"
        (snd outfile);
      if not (quiet ()) then (
        let machine_readable = machine_readable () <> None in
        Progress.set_up_progress_bar ~machine_readable g
      );
      g#launch ();

      g (* Return new handle. *)
    )
    else g (* Return existing handle. *) in

  if to_be_expanded then (
    (* Helper function to expand partition or LV content. *)
    let do_expand_content target =
      let with_mounted dev (resize : string -> unit) =
        (* Btrfs and XFS need to mount the filesystem to resize it. *)
        assert (Array.length (g#mounts ()) = 0);
        g#mount dev "/";
        resize "/";
        g#umount "/"
      in
      function
      | PVResize -> g#pvresize target
      | Resize2fs -> g#resize2fs target
      | NTFSResize -> g#ntfsresize ~force:ntfsresize_force target
      | BtrfsFilesystemResize -> with_mounted target g#btrfs_filesystem_resize
      | XFSGrowFS -> with_mounted target g#xfs_growfs
      | Mkswap ->
        (* Rebuild the swap using the UUID and label of the existing
         * swap partition.
         *)
        let orig_uuid = g#vfs_uuid target in
        let uuid =
          match orig_uuid with
          | "" -> None
          | uuid -> Some uuid in
        let label = g#vfs_label target in
        g#mkswap ?uuid ~label target;
        (* Check whether the UUID could be set, and warn in case it
         * changed.
         *)
        let new_uuid = g#vfs_uuid target in
        if new_uuid <> orig_uuid then
          warning (f_"UUID in swap partition %s changed from ‘%s’ to ‘%s’")
            target orig_uuid new_uuid;
      | ResizeF2fs -> g#f2fs_expand target
    in

    (* Expand partition content as required. *)
    let expand_partition_content = function
      | ({ p_operation = OpResize _ } as p)
          when can_expand_content p.p_type ->
          let source = p.p_name in
          let target = sprintf "/dev/sda%d" p.p_target_partnum in
          let meth = expand_content_method p.p_type in

          message (f_"Expanding %s%s using the ‘%s’ method")
            source
            (if source <> target then sprintf " (now %s)" target else "")
            (string_of_expand_content_method meth);

          do_expand_content target meth
      | { p_operation = (OpCopy | OpIgnore | OpDelete | OpResize _) }
        -> ()
    in
    List.iter expand_partition_content partitions;

    (* Expand logical volume content as required. *)
    List.iter (
      function
      | ({ lv_operation = LVOpExpand } as lv)
          when can_expand_content lv.lv_type ->
          let name = lv.lv_name in
          let meth = expand_content_method lv.lv_type in

          message (f_"Expanding %s using the ‘%s’ method")
            name (string_of_expand_content_method meth);

          (* First expand the LV itself to maximum size. *)
          g#lvresize_free name 100;

          (* Then expand the content in the LV. *)
          do_expand_content name meth
      | { lv_operation = (LVOpExpand | LVOpNone) } -> ()
    ) lvs
  );

  (* Finished.  Unmount disks and exit. *)
  g#shutdown ();
  g#close ();

  (* Try to sync the destination disk only if it is a local file. *)
  (match outfile with
  | _, { URI.protocol = (""|"file"); path } ->
    (* Because we used cache=unsafe when writing the output file, the
     * file might not be committed to disk.  This is a problem if qemu is
     * immediately used afterwards with cache=none (which uses O_DIRECT
     * and therefore bypasses the host cache).  In general you should not
     * use cache=none.
     *)
    Fsync.file path
  | _ -> ());

  if not (quiet ()) then (
    print_newline ();
    wrap (s_"Resize operation completed with no errors.  Before deleting the old disk, carefully check that the resized disk boots and works correctly.\n");
  )

let () = run_main_and_handle_errors main