Complete rewrite of virt-df:
authorRichard W.M. Jones <rjones@redhat.com>
Mon, 14 Apr 2008 16:48:49 +0000 (17:48 +0100)
committerRichard W.M. Jones <rjones@redhat.com>
Mon, 14 Apr 2008 16:48:49 +0000 (17:48 +0100)
  - Uses pa_bitmatch for robust parsing of disk structures.
  - Completely modularized.

virt-df/virt_df.ml
virt-df/virt_df_ext2.ml
virt-df/virt_df_linux_swap.ml
virt-df/virt_df_lvm2.ml
virt-df/virt_df_main.ml [changed mode: 0755->0644]
virt-df/virt_df_mbr.ml [new file with mode: 0644]

index 4fbc706..b972837 100644 (file)
@@ -25,51 +25,163 @@ open Virt_df_gettext.Gettext
 
 module C = Libvirt.Connect
 module D = Libvirt.Domain
-module N = Libvirt.Network
 
-(* Int64 operators for convenience.
- * For sanity we do all int operations as int64's.
- *)
-let (+^) = Int64.add
-let (-^) = Int64.sub
-let ( *^ ) = Int64.mul
-let (/^) = Int64.div
+(* If set to true, then emit lots of debugging information. *)
+let debug = true
 
-let uri = ref None
-let inodes = ref false
-let human = ref false
-let all = ref false
+(* Int32 infix operators for convenience. *)
+let ( +* ) = Int32.add
+let ( -* ) = Int32.sub
+let ( ** ) = Int32.mul
+let ( /* ) = Int32.div
 
-(* Maximum number of extended partitions possible. *)
-let max_extended_partitions = 100
+(* Int64 infix operators for convenience. *)
+let ( +^ ) = Int64.add
+let ( -^ ) = Int64.sub
+let ( *^ ) = Int64.mul
+let ( /^ ) = Int64.div
+
+(* State of command line arguments. *)
+let uri = ref None                     (* Hypervisor/libvirt URI. *)
+let inodes = ref false                 (* Display inodes. *)
+let human = ref false                  (* Display human-readable. *)
+let all = ref false                    (* Show all/active domains. *)
+let test_files = ref []                        (* Used for test mode only. *)
+
+(*----------------------------------------------------------------------*)
+(* The "domain/device model" that we currently understand looks
+ * like this:
+ *
+ * domains
+ *   |
+ *   \--- host partitions / disk image files
+ *          ||
+ *        guest block devices
+ *          |
+ *          +--> guest partitions (eg. using MBR)
+ *          |      |
+ *          \-(1)->+--- filesystems (eg. ext3)
+ *                 |
+ *                 \--- PVs for LVM
+ *                        |||
+ *                      VGs and LVs
+ *
+ * (1) Filesystems and PVs may also appear directly on guest
+ * block devices.
+ *
+ * Partition schemes (eg. MBR) and filesystems register themselves
+ * with this main module and they are queried first to get an idea
+ * of the physical devices, partitions and filesystems potentially
+ * available to the guest.
+ *
+ * Volume management schemes (eg. LVM) register themselves here
+ * and are called later with "spare" physical devices and partitions
+ * to see if they contain LVM data.  If this results in additional
+ * logical volumes then these are checked for filesystems.
+ *
+ * Swap space is considered to be a dumb filesystem for the purposes
+ * of this discussion.
+ *)
 
-let sector_size = 512L
+(* A virtual (or physical!) device, encapsulating any translation
+ * that has to be done to access the device.  eg. For partitions
+ * there is a simple offset, but for LVM you may need complicated
+ * table lookups.
+ *
+ * We keep the underlying file descriptors open for the duration
+ * of the program.  There aren't likely to be many of them, and
+ * the program is short-lived, and it's easier than trying to
+ * track which device is using what fd.  As a result, there is no
+ * need for any close/deallocation function.
+ *
+ * Note the very rare use of OOP in OCaml!
+ *)
+class virtual device =
+object (self)
+  method virtual read : int64 -> int -> string
+  method virtual size : int64
+  method virtual name : string
+
+  (* Helper method to read a chunk of data into a bitstring. *)
+  method read_bitstring offset len =
+    let str = self#read offset len in
+    (str, 0, len * 8)
+end
+
+(* A concrete device which just direct-maps a file or /dev device. *)
+class block_device filename =
+  let fd = openfile filename [ O_RDONLY ] 0 in
+  let size = (LargeFile.fstat fd).LargeFile.st_size in
+object (self)
+  inherit device
+  method read offset len =
+    ignore (LargeFile.lseek fd offset SEEK_SET);
+    let str = String.make len '\000' in
+    read fd str 0 len;
+    str
+  method size = size
+  method name = filename
+end
+
+(* A null device.  Any attempt to read generates an error. *)
+let null_device : device =
+object
+  inherit device
+  method read _ _ = assert false
+  method size = 0L
+  method name = "null"
+end
+
+(* Domains and candidate guest block devices. *)
 
-(* Parse out the device XML to get the names of disks. *)
 type domain = {
   dom_name : string;                   (* Domain name. *)
   dom_id : int option;                 (* Domain ID (if running). *)
   dom_disks : disk list;               (* Domain disks. *)
 }
 and disk = {
+  (* From the XML ... *)
   d_type : string option;              (* The <disk type=...> *)
-  d_device : string option;            (* The <disk device=...> *)
-  d_source : string option;            (* The <source file=... or dev> *)
-  d_target : string option;            (* The <target dev=...> *)
-}
+  d_device : string;                   (* The <disk device=...> (eg "disk") *)
+  d_source : string;                   (* The <source file=... or dev> *)
+  d_target : string;                   (* The <target dev=...> (eg "hda") *)
 
-type partition = {
+  (* About the device itself. *)
+  d_dev : device;                      (* Disk device. *)
+  d_content : disk_content;            (* What's on it. *)
+}
+and disk_content =
+  [ `Unknown                           (* Not probed or unknown. *)
+  | `Partitions of partitions          (* Contains partitions. *)
+  | `Filesystem of filesystem          (* Contains a filesystem directly. *)
+  | `PhysicalVolume of unit            (* Contains an LVM PV. *)
+  ]
+
+(* Partitions. *)
+
+and partitions = {
+  parts_name : string;                 (* Name of partitioning scheme. *)
+  parts : partition list               (* Partitions. *)
+}
+and partition = {
   part_status : partition_status;      (* Bootable, etc. *)
-  part_type : int;                     (* Partition type. *)
-  part_lba_start : int64;              (* LBA start sector. *)
-  part_len : int64;                    (* Length in sectors. *)
+  part_type : int;                     (* Partition filesystem type. *)
+  part_dev : device;                   (* Partition device. *)
+  part_content : partition_content;    (* What's on it. *)
 }
 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
-
-type filesystem_stats = {
-  fs_name : string;
+and partition_content =
+  [ `Unknown                           (* Not probed or unknown. *)
+  | `Filesystem of filesystem          (* Filesystem. *)
+  | `PhysicalVolume of unit            (* Contains an LVM PV. *)
+  ]
+
+(* Filesystems (also swap devices). *)
+and filesystem = {
+  fs_name : string;                    (* Name of filesystem. *)
   fs_block_size : int64;               (* Block size (bytes). *)
   fs_blocks_total : int64;             (* Total blocks. *)
+  fs_is_swap : bool;                   (* If swap, following not valid. *)
   fs_blocks_reserved : int64;          (* Blocks reserved for super-user. *)
   fs_blocks_avail : int64;             (* Blocks free (available). *)
   fs_blocks_used : int64;              (* Blocks in use. *)
@@ -78,250 +190,80 @@ type filesystem_stats = {
   fs_inodes_avail : int64;             (* Inodes free (available). *)
   fs_inodes_used : int64;              (* Inodes in use. *)
 }
-and swap_stats = {
-  swap_name : string;
-  swap_block_size : int64;             (* Block size (bytes). *)
-  swap_blocks_total : int64;           (* Total blocks. *)
-}
-and fs_probe_t =                       (* Return type of the probe_partition.*)
-  | Filesystem of filesystem_stats
-  | Swap of swap_stats
-  | ProbeFailed of string              (* Probe failed for some reason. *)
-  | ProbeIgnore                                (* This filesystem should be ignored. *)
-
-(* Register a filesystem type. *)
-let filesystems = Hashtbl.create 13
-let fs_register part_types probe_fn =
-  List.iter
-    (fun part_type -> Hashtbl.replace filesystems part_type probe_fn)
-    part_types
-
-(* Probe the devices and display.
- * - dom_name is the domain name
- * - target will be something like "hda"
- * - source will be the name of a file or disk partition on the local machine
- *)
-let rec probe_device dom_name target source =
-  let fd = openfile source [ O_RDONLY ] 0 in
-  let size = (LargeFile.fstat fd).LargeFile.st_size in
-  let size = size /^ sector_size in    (* Size in sectors. *)
-
-  (*print_device dom_name target source size;*)
-
-  let partitions = probe_mbr fd in
-
-  if partitions <> [] then (
-    let stats =
-      List.mapi (
-       fun i part ->
-         if part.part_status = Bootable ||
-           part.part_status = Nonbootable then (
-             let pnum = i+1 in
-             let target = target ^ string_of_int pnum in
-             Some (target,
-                   probe_partition target (Some part.part_type)
-                     fd part.part_lba_start part.part_len)
-           )
-         else
-           None
-      ) partitions in
-    let stats = List.filter_map (fun x -> x) stats in
-    print_stats dom_name stats
-  ) else            (* Not an MBR, assume it's a single partition. *)
-    print_stats dom_name [target, probe_partition target None fd 0L size];
-
-  close fd
-
-(* Probe the master boot record (if it is one) and read the partitions.
- * Returns [] if this is not an MBR.
- * http://en.wikipedia.org/wiki/Master_boot_record
- *)
-and probe_mbr fd =
-  lseek fd 510 SEEK_SET;
-  let str = String.create 2 in
-  if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then
-    [] (* Not MBR *)
-  else (
-    (* Read the partition table. *)
-    lseek fd 446 SEEK_SET;
-    let str = String.create 64 in
-    if read fd str 0 64 <> 64 then
-      failwith (s_ "error reading partition table")
-    else (
-      (* Extract partitions from the data. *)
-      let primaries = List.map (get_partition str) [ 0; 16; 32; 48 ] in
-      (* XXX validate partition extents compared to disk. *)
-      (* Read extended partition data. *)
-      let extendeds = List.map (
-       function
-       | { part_type = 0x05 } as part ->
-           probe_extended_partition
-             max_extended_partitions fd part part.part_lba_start
-       | part -> []
-      ) primaries in
-      let extendeds = List.concat extendeds in
-      primaries @ extendeds
-    )
-  )
-
-(* Probe an extended partition. *)
-and probe_extended_partition max fd epart sect =
-  if max > 0 then (
-    (* Offset of the first EBR. *)
-    let ebr_offs = sect *^ sector_size in
-    (* EBR Signature? *)
-    LargeFile.lseek fd (ebr_offs +^ 510L) SEEK_SET;
-    let str = String.create 2 in
-    if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then
-      [] (* Not EBR *)
-    else (
-      (* Read the extended partition table entries (just 2 of them). *)
-      LargeFile.lseek fd (ebr_offs +^ 446L) SEEK_SET;
-      let str = String.create 32 in
-      if read fd str 0 32 <> 32 then
-       failwith (s_ "error reading extended partition")
-      else (
-       (* Extract partitions from the data. *)
-       let part1, part2 =
-         match List.map (get_partition str) [ 0; 16 ] with
-         | [p1;p2] -> p1,p2
-         | _ -> failwith (s_ "probe_extended_partition: internal error") in
-       (* First partition entry has offset to the start of this partition. *)
-       let part1 = { part1 with
-                       part_lba_start = sect +^ part1.part_lba_start } in
-       (* Second partition entry is zeroes if end of list, otherwise points
-        * to the next partition.
-        *)
-       if part2.part_status = NullEntry then
-         [part1]
-       else
-         part1 :: probe_extended_partition
-                    (max-1) fd epart (sect +^ part2.part_lba_start)
-      )
-    )
-  )
-  else []
-
-(* Get the partition data from str.[offs] - str.[offs+15] *)
-and get_partition str offs =
-  let part_type = Char.code str.[offs+4] in
-  let part_lba_start = read_int32_le str (offs+8) in
-  let part_len = read_int32_le str (offs+12) in
-
-  let part_status =
-    if part_type = 0 && part_lba_start = 0L && part_len = 0L then
-      NullEntry
-    else (
-      let part_status = Char.code str.[offs] in
-      match part_status with
-      | 0x80 -> Bootable | 0 -> Nonbootable | _ -> Malformed
-    ) in
-
-  { part_status = part_status;
-    part_type = part_type;
-    part_lba_start = part_lba_start;
-    part_len = part_len }
-
-(* Probe a single partition, which we assume contains either a
- * filesystem or is a PV.
- * - target will be something like "hda" or "hda1"
- * - part_type will be the partition type if known, or None
- * - fd is a file descriptor opened on the device
- * - start & size are where we think the start and size of the
- *   partition is within the file descriptor (in SECTORS)
- *)
-and probe_partition target part_type fd start size =
-  match part_type with
-  | None ->
-      ProbeFailed (s_ "detection of unpartitioned devices not yet supported")
-  | Some 0x05 ->
-      ProbeIgnore (* Extended partition - ignore it. *)
-  | Some part_type ->
-      try
-       let probe_fn = Hashtbl.find filesystems part_type in
-       probe_fn target part_type fd start size
-      with
-       Not_found ->
-         ProbeFailed
-           (sprintf (f_ "unsupported partition type %02x") part_type)
-
-and print_stats dom_name statss =
-  List.iter (
-    fun (target, fs_probe_t) ->
-      let dom_target = dom_name ^ ":" ^ target in
-      printf "%-20s " dom_target;
-
-      match fs_probe_t with
-      (* Swap partition. *)
-      | Swap { swap_name = swap_name;
-              swap_block_size = block_size;
-              swap_blocks_total = blocks_total } ->
-         if not !human then
-           printf "%10Ld                       %s\n"
-             (block_size *^ blocks_total /^ 1024L) swap_name
-         else
-           printf "%10s                       %s\n"
-             (printable_size (block_size *^ blocks_total)) swap_name
 
-      (* Ordinary filesystem. *)
-      | Filesystem stats ->
-         if not !inodes then (         (* Block display. *)
-           (* 'df' doesn't count the restricted blocks. *)
-           let blocks_total =
-             stats.fs_blocks_total -^ stats.fs_blocks_reserved in
-           let blocks_avail =
-             stats.fs_blocks_avail -^ stats.fs_blocks_reserved in
-           let blocks_avail =
-             if blocks_avail < 0L then 0L else blocks_avail in
-
-           if not !human then (        (* Display 1K blocks. *)
-             printf "%10Ld %10Ld %10Ld %s\n"
-               (blocks_total *^ stats.fs_block_size /^ 1024L)
-               (stats.fs_blocks_used *^ stats.fs_block_size /^ 1024L)
-               (blocks_avail *^ stats.fs_block_size /^ 1024L)
-               stats.fs_name
-           ) else (                    (* Human-readable blocks. *)
-             printf "%10s %10s %10s %s\n"
-               (printable_size (blocks_total *^ stats.fs_block_size))
-               (printable_size (stats.fs_blocks_used *^ stats.fs_block_size))
-               (printable_size (blocks_avail *^ stats.fs_block_size))
-               stats.fs_name
-           )
-         ) else (                      (* Inodes display. *)
-           printf "%10Ld %10Ld %10Ld %s\n"
-             stats.fs_inodes_total stats.fs_inodes_used stats.fs_inodes_avail
-             stats.fs_name
-         )
-
-      (* Unsupported filesystem or other failure. *)
-      | ProbeFailed reason ->
-         printf "                                 %s\n" reason
-
-      | ProbeIgnore -> ()
-  ) statss
-
-(* Target is something like "hda" and size is the size in sectors. *)
-and print_device dom_name target source size =
-  printf "%s /dev/%s (%s) %s\n"
-    dom_name target (printable_size (size *^ sector_size)) source
-
-and printable_size bytes =
-  if bytes < 1024L *^ 1024L then
-    sprintf "%Ld bytes" bytes
-  else if bytes < 1024L *^ 1024L *^ 1024L then
-    sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
-  else
-    sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
-
-and read_int32_le str offs =
-  Int64.of_int (Char.code str.[offs]) +^
-    256L *^ Int64.of_int (Char.code str.[offs+1]) +^
-    65536L *^ Int64.of_int (Char.code str.[offs+2]) +^
-    16777216L *^ Int64.of_int (Char.code str.[offs+3])
-
-and read_int16_le str offs =
-  Int64.of_int (Char.code str.[offs]) +^
-    256L *^ Int64.of_int (Char.code str.[offs+1])
+(* Convert partition, filesystem types to printable strings for debugging. *)
+let string_of_partition
+    { part_status = status; part_type = typ; part_dev = dev } =
+  sprintf "%s: %s partition type %d"
+    dev#name
+    (match status with
+     | Bootable -> "bootable"
+     | Nonbootable -> "nonbootable"
+     | Malformed -> "malformed"
+     | NullEntry -> "empty")
+    typ
+
+let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
+  if not swap then name
+  else name ^ " [swap]"
+
+(* Register a partition scheme. *)
+let partition_types = ref []
+let partition_type_register (parts_name : string) probe_fn =
+  partition_types := (parts_name, probe_fn) :: !partition_types
+
+(* Probe a device for partitions.  Returns [Some parts] or [None]. *)
+let probe_for_partitions dev =
+  if debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
+  let rec loop = function
+    | [] -> None
+    | (parts_name, probe_fn) :: rest ->
+       try Some (probe_fn dev)
+       with Not_found -> loop rest
+  in
+  let r = loop !partition_types in
+  if debug then (
+    match r with
+    | None -> eprintf "no partitions found on %s\n%!" dev#name
+    | Some { parts_name = name; parts = parts } ->
+       eprintf "found %d %s partitions on %s:\n"
+         (List.length parts) name dev#name;
+       List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts
+  );
+  r
+
+(* Register a filesystem type (or swap). *)
+let filesystem_types = ref []
+let filesystem_type_register (fs_name : string) probe_fn =
+  filesystem_types := (fs_name, probe_fn) :: !filesystem_types
+
+(* Probe a device for filesystems.  Returns [Some fs] or [None]. *)
+let probe_for_filesystems dev =
+  if debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
+  let rec loop = function
+    | [] -> None
+    | (fs_name, probe_fn) :: rest ->
+       try Some (probe_fn dev)
+       with Not_found -> loop rest
+  in
+  let r = loop !filesystem_types in
+  if debug then (
+    match r with
+    | None -> eprintf "no filesystem found on %s\n%!" dev#name
+    | Some fs ->
+       eprintf "found a filesystem on %s:\n" dev#name;
+       eprintf "\t%s\n%!" (string_of_filesystem fs)
+  );
+  r
+
+(* Register a volume management type. *)
+(*
+let lvm_types = ref []
+let lvm_type_register (lvm_name : string) probe_fn =
+  lvm_types := (lvm_name, probe_fn) :: !lvm_types
+*)
+
+(*----------------------------------------------------------------------*)
 
 let main () =
   (* Command line argument parsing. *)
@@ -337,6 +279,10 @@ let main () =
     exit 0
   in
 
+  let test_mode filename =
+    test_files := filename :: !test_files
+  in
+
   let argspec = Arg.align [
     "-a", Arg.Set all,
       " " ^ s_ "Show all domains (default: only active domains)";
@@ -354,6 +300,8 @@ let main () =
       " " ^ s_ "Show inodes instead of blocks";
     "--inodes", Arg.Set inodes,
       " " ^ s_ "Show inodes instead of blocks";
+    "-t", Arg.String test_mode,
+      "dev" ^ s_ "(Test mode) Display contents of block device or file";
     "--version", Arg.Unit version,
       " " ^ s_ "Display version and exit";
   ] in
@@ -369,127 +317,230 @@ OPTIONS" in
 
   Arg.parse argspec anon_fun usage_msg;
 
-  let xmls =
-    (* Connect to the hypervisor. *)
-    let conn =
-      let name = !uri in
-      try C.connect_readonly ?name ()
-      with
-       Libvirt.Virterror err ->
-         prerr_endline (Libvirt.Virterror.to_string err);
-         (* If non-root and no explicit connection URI, print a warning. *)
-         if geteuid () <> 0 && name = None then (
-           print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root");
-         );
-         exit 1 in
-
-    (* Get the list of active & inactive domains. *)
-    let doms =
-      let nr_active_doms = C.num_of_domains conn in
-      let active_doms = Array.to_list (C.list_domains conn nr_active_doms) in
-      let active_doms = List.map (D.lookup_by_id conn) active_doms in
-      if not !all then
-       active_doms
-      else (
-       let nr_inactive_doms = C.num_of_defined_domains conn in
-       let inactive_doms =
-         Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
-       let inactive_doms = List.map (D.lookup_by_name conn) inactive_doms in
-       active_doms @ inactive_doms
-      ) in
-
-    (* Get their XML. *)
-    let xmls = List.map D.get_xml_desc doms in
-
-    (* Parse the XML. *)
-    let xmls = List.map Xml.parse_string xmls in
-
-    (* Return just the XML documents - everything else will be closed
-     * and freed including the connection to the hypervisor.
-     *)
-    xmls in
-
   let doms : domain list =
-    (* Grr.. Need to use a library which has XPATH support (or cduce). *)
-    List.map (
-      fun xml ->
-       let nodes, domain_attrs =
-         match xml with
-         | Xml.Element ("domain", attrs, children) -> children, attrs
-         | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in
-
-       let domid =
-         try Some (int_of_string (List.assoc "id" domain_attrs))
-         with Not_found -> None in
-
-       let rec loop = function
-         | [] ->
-             failwith (s_ "get_xml_desc returned no <name> node in XML")
-         | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
-         | Xml.Element ("name", _, _) :: _ ->
-             failwith (s_ "get_xml_desc returned strange <name> node")
-         | _ :: rest -> loop rest
-       in
-       let name = loop nodes in
-
-       let devices =
+    if !test_files = [] then (
+      let xmls =
+       (* Connect to the hypervisor. *)
+       let conn =
+         let name = !uri in
+         try C.connect_readonly ?name ()
+         with
+           Libvirt.Virterror err ->
+             prerr_endline (Libvirt.Virterror.to_string err);
+             (* If non-root and no explicit connection URI, print a warning. *)
+             if geteuid () <> 0 && name = None then (
+               print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root");
+             );
+             exit 1 in
+
+       (* Get the list of active & inactive domains. *)
+       let doms =
+         let nr_active_doms = C.num_of_domains conn in
+         let active_doms =
+           Array.to_list (C.list_domains conn nr_active_doms) in
+         let active_doms =
+           List.map (D.lookup_by_id conn) active_doms in
+         if not !all then
+           active_doms
+         else (
+           let nr_inactive_doms = C.num_of_defined_domains conn in
+           let inactive_doms =
+             Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
+           let inactive_doms =
+             List.map (D.lookup_by_name conn) inactive_doms in
+           active_doms @ inactive_doms
+         ) in
+
+       (* Get their XML. *)
+       let xmls = List.map D.get_xml_desc doms in
+
+       (* Parse the XML. *)
+       let xmls = List.map Xml.parse_string xmls in
+
+       (* Return just the XML documents - everything else will be closed
+        * and freed including the connection to the hypervisor.
+        *)
+       xmls in
+
+      (* Grr.. Need to use a library which has XPATH support (or cduce). *)
+      List.map (
+       fun xml ->
+         let nodes, domain_attrs =
+           match xml with
+           | Xml.Element ("domain", attrs, children) -> children, attrs
+           | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in
+
+         let domid =
+           try Some (int_of_string (List.assoc "id" domain_attrs))
+           with Not_found -> None in
+
+         let rec loop = function
+           | [] ->
+               failwith (s_ "get_xml_desc returned no <name> node in XML")
+           | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
+           | Xml.Element ("name", _, _) :: _ ->
+               failwith (s_ "get_xml_desc returned strange <name> node")
+           | _ :: rest -> loop rest
+         in
+         let name = loop nodes in
+
          let devices =
+           let devices =
+             List.filter_map (
+               function
+               | Xml.Element ("devices", _, devices) -> Some devices
+               | _ -> None
+             ) nodes in
+           List.concat devices in
+
+         let rec target_dev_of = function
+           | [] -> None
+           | Xml.Element ("target", attrs, _) :: rest ->
+               (try Some (List.assoc "dev" attrs)
+                with Not_found -> target_dev_of rest)
+           | _ :: rest -> target_dev_of rest
+         in
+
+         let rec source_file_of = function
+           | [] -> None
+           | Xml.Element ("source", attrs, _) :: rest ->
+               (try Some (List.assoc "file" attrs)
+                with Not_found -> source_file_of rest)
+           | _ :: rest -> source_file_of rest
+         in
+
+         let rec source_dev_of = function
+           | [] -> None
+           | Xml.Element ("source", attrs, _) :: rest ->
+               (try Some (List.assoc "dev" attrs)
+                with Not_found -> source_dev_of rest)
+           | _ :: rest -> source_dev_of rest
+         in
+
+         let disks =
            List.filter_map (
              function
-             | Xml.Element ("devices", _, devices) -> Some devices
+             | Xml.Element ("disk", attrs, children) ->
+                 let typ =
+                   try Some (List.assoc "type" attrs)
+                   with Not_found -> None in
+                 let device =
+                   try Some (List.assoc "device" attrs)
+                   with Not_found -> None in
+                 let source =
+                   match source_file_of children with
+                   | (Some _) as source -> source
+                   | None -> source_dev_of children in
+                 let target = target_dev_of children in
+
+                 (* We only care about devices where we have
+                  * source and target.  Ignore CD-ROM devices.
+                  *)
+                 (match source, target, device with
+                  | _, _, Some "cdrom" -> None (* ignore *)
+                  | Some source, Some target, Some device ->
+                      (* Try to create a 'device' object for this
+                       * device.  If it fails, print a warning
+                       * and ignore the device.
+                       *)
+                      (try
+                         let dev = new block_device source in
+                         Some {
+                           d_type = typ; d_device = device;
+                           d_source = source; d_target = target;
+                           d_dev = dev; d_content = `Unknown
+                         }
+                       with
+                         Unix_error (err, func, param) ->
+                           eprintf "%s:%s: %s" func param (error_message err);
+                           None
+                      )
+                  | _ -> None (* ignore anything else *)
+                 )
+
              | _ -> None
-           ) nodes in
-         List.concat devices in
-
-       let rec target_dev_of = function
-         | [] -> None
-         | Xml.Element ("target", attrs, _) :: rest ->
-             (try Some (List.assoc "dev" attrs)
-              with Not_found -> target_dev_of rest)
-         | _ :: rest -> target_dev_of rest
-       in
-
-       let rec source_file_of = function
-         | [] -> None
-         | Xml.Element ("source", attrs, _) :: rest ->
-             (try Some (List.assoc "file" attrs)
-              with Not_found -> source_file_of rest)
-         | _ :: rest -> source_file_of rest
-       in
-
-       let rec source_dev_of = function
-         | [] -> None
-         | Xml.Element ("source", attrs, _) :: rest ->
-             (try Some (List.assoc "dev" attrs)
-              with Not_found -> source_dev_of rest)
-         | _ :: rest -> source_dev_of rest
-       in
-
-       let disks =
-         List.filter_map (
-           function
-           | Xml.Element ("disk", attrs, children) ->
-               let typ =
-                 try Some (List.assoc "type" attrs)
-                 with Not_found -> None in
-               let device =
-                 try Some (List.assoc "device" attrs)
-                 with Not_found -> None in
-               let source =
-                 match source_file_of children with
-                 | (Some _) as source -> source
-                 | None -> source_dev_of children in
-               let target = target_dev_of children in
-
-               Some {
-                 d_type = typ; d_device = device;
-                 d_source = source; d_target = target
-               }
-           | _ -> None
-         ) devices in
-
-       { dom_name = name; dom_id = domid; dom_disks = disks }
-    ) xmls in
+           ) devices in
+
+         { dom_name = name; dom_id = domid; dom_disks = disks }
+      ) xmls
+    ) else (
+      (* In test mode (-t option) the user can pass one or more
+       * block devices or filenames (containing partitions/filesystems/etc)
+       * which we use for testing virt-df itself.  We create fake domains
+       * from these.
+       *)
+      List.map (
+       fun filename ->
+         {
+           dom_name = filename; dom_id = None;
+           dom_disks = [
+             {
+               d_type = Some "disk"; d_device = "disk";
+               d_source = filename; d_target = "hda";
+               d_dev = new block_device filename; d_content = `Unknown;
+             }
+           ]
+         }
+      ) !test_files
+    ) in
+
+  (* HOF to map over disks. *)
+  let map_over_disks doms f =
+    List.map (
+      fun ({ dom_disks = disks } as dom) ->
+       let disks = List.map f disks in
+       { dom with dom_disks = disks }
+    ) doms
+  in
+
+  (* 'doms' is our list of domains and their guest block devices, and
+   * we've successfully opened each block device.  Now probe them
+   * to find out what they contain.
+   *)
+  let doms = map_over_disks doms (
+    fun ({ d_dev = dev } as disk) ->
+      (* See if it is partitioned first. *)
+      let parts = probe_for_partitions dev in
+      match parts with
+      | Some parts ->
+         { disk with d_content = `Partitions parts }
+      | None ->
+         (* Not partitioned.  Does it contain a filesystem? *)
+         let fs = probe_for_filesystems dev in
+         match fs with
+         | Some fs ->
+             { disk with d_content = `Filesystem fs }
+         | None ->
+             (* Not partitioned, no filesystem, so it's spare. *)
+             disk
+  ) in
+
+  (* Now we have either detected partitions or a filesystem on each
+   * physical device (or perhaps neither).  See what is on those
+   * partitions.
+   *)
+  let doms = map_over_disks doms (
+    function
+    | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
+       let ps = List.map (
+         fun p ->
+           if p.part_status = Bootable || p.part_status = Nonbootable then (
+             let fs = probe_for_filesystems p.part_dev in
+             match fs with
+             | Some fs ->
+                 { p with part_content = `Filesystem fs }
+             | None ->
+                 p
+           ) else p
+       ) parts.parts in
+       let parts = { parts with parts = ps } in
+       { disk with d_content = `Partitions parts }
+    | disk -> disk
+  ) in
+
+  (* XXX LVM stuff here. *)
+
+
 
   (* Print the title. *)
   let () =
@@ -501,16 +552,108 @@ OPTIONS" in
     printf "%-20s %10s %10s %10s %s\n%!"
       (s_ "Filesystem") total used avail (s_ "Type") in
 
-  (* Probe the devices. *)
-  List.iter (
-    fun { dom_name = dom_name; dom_disks = dom_disks } ->
-      List.iter (
-       function
-       | { d_source = Some source; d_target = Some target } ->
-           probe_device dom_name target source
-       | { d_device = Some "cdrom" } ->
-           () (* Ignore physical CD-ROM devices. *)
-       | _ ->
-           print_endline (s_ "(device omitted)");
-      ) dom_disks
-  ) doms
+  let printable_size bytes =
+    if bytes < 1024L *^ 1024L then
+      sprintf "%Ld bytes" bytes
+    else if bytes < 1024L *^ 1024L *^ 1024L then
+      sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
+    else
+      sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
+  in
+
+  (* HOF to iterate over filesystems. *)
+  let iter_over_filesystems doms f =
+    List.iter (
+      fun ({ dom_disks = disks } as dom) ->
+       List.iter (
+         function
+         | ({ d_content = `Filesystem fs } as disk) ->
+             f dom disk None fs
+         | ({ d_content = `Partitions partitions } as disk) ->
+             List.iteri (
+               fun i ->
+                 function
+                 | ({ part_content = `Filesystem fs } as part) ->
+                     f dom disk (Some (part, i)) fs
+                 | _ -> ()
+             ) partitions.parts
+         | _ -> ()
+       ) disks
+    ) doms
+  in
+
+  (* Print stats for each recognized filesystem. *)
+  let print_stats dom disk part fs =
+    (* Printable name is like "domain:hda" or "domain:hda1". *)
+    let name =
+      let dom_name = dom.dom_name in
+      let d_target = disk.d_target in
+      match part with
+      | None ->
+         dom_name ^ ":" ^ d_target
+      | Some (_, pnum) ->
+         dom_name ^ ":" ^ d_target ^ string_of_int pnum in
+    printf "%-20s " name;
+
+    if fs.fs_is_swap then (
+      (* Swap partition. *)
+      if not !human then
+       printf "%10Ld                       %s\n"
+         (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L) fs.fs_name
+      else
+       printf "%10s                       %s\n"
+         (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name
+    ) else (
+      (* Ordinary filesystem. *)
+      if not !inodes then (            (* Block display. *)
+       (* 'df' doesn't count the restricted blocks. *)
+       let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
+       let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in
+       let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
+
+       if not !human then (            (* Display 1K blocks. *)
+         printf "%10Ld %10Ld %10Ld %s\n"
+           (blocks_total *^ fs.fs_block_size /^ 1024L)
+           (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L)
+           (blocks_avail *^ fs.fs_block_size /^ 1024L)
+           fs.fs_name
+       ) else (                        (* Human-readable blocks. *)
+         printf "%10s %10s %10s %s\n"
+           (printable_size (blocks_total *^ fs.fs_block_size))
+           (printable_size (fs.fs_blocks_used *^ fs.fs_block_size))
+           (printable_size (blocks_avail *^ fs.fs_block_size))
+           fs.fs_name
+       )
+      ) else (                         (* Inodes display. *)
+       printf "%10Ld %10Ld %10Ld %s\n"
+         fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail
+         fs.fs_name
+      )
+    )
+  in
+  iter_over_filesystems doms print_stats
+
+(*
+(* Probe a single partition, which we assume contains either a
+ * filesystem or is a PV.
+ * - target will be something like "hda" or "hda1"
+ * - part_type will be the partition type if known, or None
+ * - fd is a file descriptor opened on the device
+ * - start & size are where we think the start and size of the
+ *   partition is within the file descriptor (in SECTORS)
+ *)
+and probe_partition target part_type fd start size =
+  match part_type with
+  | None ->
+      ProbeFailed (s_ "detection of unpartitioned devices not yet supported")
+  | Some 0x05 ->
+      ProbeIgnore (* Extended partition - ignore it. *)
+  | Some part_type ->
+      try
+       let probe_fn = Hashtbl.find filesystems part_type in
+       probe_fn target part_type fd start size
+      with
+       Not_found ->
+         ProbeFailed
+           (sprintf (f_ "unsupported partition type %02x") part_type)
+*)
index 1acd855..0ea8a25 100644 (file)
 
 open Unix
 open Printf
+
 open Virt_df_gettext.Gettext
+open Virt_df
+
+let superblock_offset = 1024L
+
+let probe_ext2 (dev : device) =
+  (* Load the superblock. *)
+  let bits = dev#read_bitstring superblock_offset 1024 in
+
+  (* The structure is straight from /usr/include/linux/ext3_fs.h *)
+  bitmatch bits with
+  | s_inodes_count : 32 : littleendian;                (* Inodes count *)
+    s_blocks_count : 32 : littleendian;                (* Blocks count *)
+    s_r_blocks_count : 32 : littleendian;      (* Reserved blocks count *)
+    s_free_blocks_count : 32 : littleendian;   (* Free blocks count *)
+    s_free_inodes_count : 32 : littleendian;   (* Free inodes count *)
+    s_first_data_block : 32 : littleendian;    (* First Data Block *)
+    s_log_block_size : 32 : littleendian;      (* Block size *)
+    s_log_frag_size : 32 : littleendian;       (* Fragment size *)
+    s_blocks_per_group : 32 : littleendian;    (* # Blocks per group *)
+    s_frags_per_group : 32 : littleendian;     (* # Fragments per group *)
+    s_inodes_per_group : 32 : littleendian;    (* # Inodes per group *)
+    s_mtime : 32 : littleendian;               (* Mount time *)
+    s_wtime : 32 : littleendian;               (* Write time *)
+    s_mnt_count : 16 : littleendian;           (* Mount count *)
+    s_max_mnt_count : 16 : littleendian;       (* Maximal mount count *)
+    0xef53 : 16 : littleendian;                        (* Magic signature *)
+    s_state : 16 : littleendian;               (* File system state *)
+    s_errors : 16 : littleendian;              (* Behaviour when detecting errors *)
+    s_minor_rev_level : 16 : littleendian;     (* minor revision level *)
+    s_lastcheck : 32 : littleendian;           (* time of last check *)
+    s_checkinterval : 32 : littleendian;       (* max. time between checks *)
+    s_creator_os : 32 : littleendian;          (* OS *)
+    s_rev_level : 32 : littleendian;           (* Revision level *)
+    s_def_resuid : 16 : littleendian;          (* Default uid for reserved blocks *)
+    s_def_resgid : 16 : littleendian;          (* Default gid for reserved blocks *)
+    s_first_ino : 32 : littleendian;           (* First non-reserved inode *)
+    s_inode_size : 16 : littleendian;          (* size of inode structure *)
+    s_block_group_nr : 16 : littleendian;      (* block group # of this superblock *)
+    s_feature_compat : 32 : littleendian;      (* compatible feature set *)
+    s_feature_incompat : 32 : littleendian;    (* incompatible feature set *)
+    s_feature_ro_compat : 32 : littleendian;   (* readonly-compatible feature set *)
+    s_uuid : 128 : bitstring;                  (* 128-bit uuid for volume *)
+    s_volume_name : 128 : bitstring;           (* volume name XXX string *)
+    s_last_mounted : 512 : bitstring;          (* directory where last mounted XXX string *)
+    s_algorithm_usage_bitmap : 32 : littleendian; (* For compression *)
+    s_prealloc_blocks : 8;                     (* Nr of blocks to try to preallocate*)
+    s_prealloc_dir_blocks : 8;                 (* Nr to preallocate for dirs *)
+    s_reserved_gdt_blocks : 16 : littleendian; (* Per group desc for online growth *)
+    s_journal_uuid : 128 : bitstring;          (* uuid of journal superblock *)
+    s_journal_inum : 32 : littleendian;                (* inode number of journal file *)
+    s_journal_dev : 32 : littleendian;         (* device number of journal file *)
+    s_last_orphan : 32 : littleendian;         (* start of list of inodes to delete *)
+    s_hash_seed0 : 32 : littleendian;          (* HTREE hash seed *)
+    s_hash_seed1 : 32 : littleendian;
+    s_hash_seed2 : 32 : littleendian;
+    s_hash_seed3 : 32 : littleendian;
+    s_def_hash_version : 8;                    (* Default hash version to use *)
+    s_reserved_char_pad : 8;
+    s_reserved_word_pad : 16 : littleendian;
+    s_default_mount_opts : 32 : littleendian;
+    s_first_meta_bg : 32 : littleendian;       (* First metablock block group *)
+    s_reserved : 6080 : bitstring ->            (* Padding to the end of the block *)
 
-(* Int64 operators for convenience. *)
-let (+^) = Int64.add
-let (-^) = Int64.sub
-let ( *^ ) = Int64.mul
-let (/^) = Int64.div
-
-let sector_size = Virt_df.sector_size
-let read_int32_le = Virt_df.read_int32_le
-
-let probe_ext2 target part_type fd start size =
-  LargeFile.lseek fd ((start+^2L) *^ sector_size) SEEK_SET;
-  let str = String.create 128 in
-  if read fd str 0 128 <> 128 then
-    failwith (s_ "error reading ext2/ext3 magic")
-  else (
-    if str.[56] != '\x53' || str.[57] != '\xEF' then (
-      Virt_df.ProbeFailed (s_ "partition marked EXT2/3 but no valid filesystem")
-    ) else (
-      (* Refer to <linux/ext2_fs.h> *)
-      let s_inodes_count = read_int32_le str 0 in
-      let s_blocks_count = read_int32_le str 4 in
-      let s_r_blocks_count = read_int32_le str 8 in
-      let s_free_blocks_count = read_int32_le str 12 in
-      let s_free_inodes_count = read_int32_le str 16 in
-      let s_first_data_block = read_int32_le str 20 in
-      let s_log_block_size = read_int32_le str 24 in
-      (*let s_log_frag_size = read_int32_le str 28 in*)
-      let s_blocks_per_group = read_int32_le str 32 in
-
-      (* Work out the block size in bytes. *)
-      let s_log_block_size = Int64.to_int s_log_block_size in
-      let block_size = 1024L in
-      let block_size = Int64.shift_left block_size s_log_block_size in
-
-      (* Number of groups. *)
-      let s_groups_count =
-       (s_blocks_count -^ s_first_data_block -^ 1L)
-       /^ s_blocks_per_group +^ 1L in
+   (* Work out the block size in bytes. *)
+   let s_log_block_size = Int32.to_int s_log_block_size in
+   let block_size = 1024L in
+   let block_size = Int64.shift_left block_size s_log_block_size in
+
+   (* Number of groups. *)
+   let s_groups_count =
+     Int64.of_int32 (
+       (s_blocks_count -* s_first_data_block -* 1l)
+       /* s_blocks_per_group +* 1l
+     ) in
 
 (*
       (* Number of group descriptors per block. *)
@@ -71,30 +107,32 @@ let probe_ext2 target part_type fd start size =
          /^ s_desc_per_block
 *)
 
-      (* Calculate the block overhead (used by superblocks, inodes, etc.)
-       * See fs/ext2/super.c.
-       *)
-      let overhead = s_first_data_block in
-      let overhead = (* XXX *) overhead in
-
-
-      Virt_df.Filesystem {
-       Virt_df.fs_name = s_ "Linux ext2/3";
-       fs_block_size = block_size;
-       fs_blocks_total = s_blocks_count -^ overhead;
-       fs_blocks_reserved = s_r_blocks_count;
-       fs_blocks_avail = s_free_blocks_count;
-       fs_blocks_used = s_blocks_count -^ overhead -^ s_free_blocks_count;
-       fs_inodes_total = s_inodes_count;
-       fs_inodes_reserved = 0L;        (* XXX? *)
-       fs_inodes_avail = s_free_inodes_count;
-       fs_inodes_used = s_inodes_count (*-^ 0L*) -^ s_free_inodes_count;
-      }
-    )
-  )
+   (* Calculate the block overhead (used by superblocks, inodes, etc.)
+    * See fs/ext2/super.c.
+    *)
+   let overhead = Int64.of_int32 s_first_data_block in
+   let overhead = (* XXX *) overhead in
+
+   {
+     fs_name = s_ "Linux ext2/3";
+     fs_block_size = block_size;
+     fs_blocks_total = Int64.of_int32 s_blocks_count -^ overhead;
+     fs_is_swap = false;
+     fs_blocks_reserved = Int64.of_int32 s_r_blocks_count;
+     fs_blocks_avail = Int64.of_int32 s_free_blocks_count;
+     fs_blocks_used =
+       Int64.of_int32 s_blocks_count -^ overhead
+       -^ Int64.of_int32 s_free_blocks_count;
+     fs_inodes_total = Int64.of_int32 s_inodes_count;
+     fs_inodes_reserved = 0L;  (* XXX? *)
+     fs_inodes_avail = Int64.of_int32 s_free_inodes_count;
+     fs_inodes_used = Int64.of_int32 s_inodes_count
+       (*-^ 0L*)
+       -^ Int64.of_int32 s_free_inodes_count;
+   }
+
+  | _ ->
+      raise Not_found                  (* Not an EXT2/3 superblock. *)
 
 (* Register with main code. *)
-let () =
-  Virt_df.fs_register
-    [ 0x83 ]                           (* Partition type. *)
-    probe_ext2
+let () = filesystem_type_register "ext2" probe_ext2
index 04e22b9..ad56149 100644 (file)
 *)
 
 open Virt_df_gettext.Gettext
-
-(* Int64 operators for convenience. *)
-let (+^) = Int64.add
-let (-^) = Int64.sub
-let ( *^ ) = Int64.mul
-let (/^) = Int64.div
-
-let probe_swap target part_type fd start size =
-  Virt_df.Swap {
-    Virt_df.swap_name = s_ "Linux swap";
-    swap_block_size = 4096L;           (* XXX *)
-    swap_blocks_total = size *^ 512L /^ 4096L;
-  }
+open Virt_df
+
+let probe_swap (dev : device) =
+  (* Load the "superblock" (ie. first 0x1000 bytes). *)
+  let bits = dev#read_bitstring 0L 0x1000 in
+
+  bitmatch bits with
+    (* Actually this isn't just padding. *)
+  | padding : 8*0x1000 - 10*8 : bitstring;
+    magic : 10*8 : bitstring
+      when Bitmatch.string_of_bitstring magic = "SWAPSPACE2" ->
+    {
+      fs_name = s_ "Linux swap";
+      fs_block_size = 4096L;           (* XXX *)
+      fs_blocks_total = dev#size /^ 4096L;
+
+      (* The remaining fields are ignored when fs_is_swap is true. *)
+      fs_is_swap = true;
+      fs_blocks_reserved = 0L;
+      fs_blocks_avail = 0L;
+      fs_blocks_used = 0L;
+      fs_inodes_total = 0L;
+      fs_inodes_reserved = 0L;
+      fs_inodes_avail = 0L;
+      fs_inodes_used = 0L;
+    }
+  | _ ->
+      raise Not_found                  (* Not Linux swapspace. *)
 
 (* Register with main code. *)
-let () =
-  Virt_df.fs_register
-    [ 0x82 ]                           (* Partition type. *)
-    probe_swap
+let () = filesystem_type_register "linux_swap" probe_swap
index d01a5a8..a79ec7f 100644 (file)
 
 open Printf
 open Virt_df_gettext.Gettext
+open Virt_df
 
-(* Int64 operators for convenience. *)
-let (+^) = Int64.add
-let (-^) = Int64.sub
-let ( *^ ) = Int64.mul
-let (/^) = Int64.div
-
-let probe_lvm2 target part_type fd start size =
-  Virt_df.ProbeFailed (s_ "LVM2 not supported yet")
+let probe_lvm2 (dev : device) =
+  raise Not_found
 
 (* Register with main code. *)
 let () =
-  Virt_df.fs_register
-    [ 0x8e ]                           (* Partition type. *)
-    probe_lvm2
+  filesystem_type_register "LVM2" probe_lvm2
old mode 100755 (executable)
new mode 100644 (file)
index bc4096b..1359b28
@@ -17,4 +17,7 @@
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  *)
 
+(* We just need this so that the filesystem modules get a chance to
+ * register themselves before we run the main program.
+ *)
 let () = Virt_df.main ()
diff --git a/virt-df/virt_df_mbr.ml b/virt-df/virt_df_mbr.ml
new file mode 100644 (file)
index 0000000..b9a6cb7
--- /dev/null
@@ -0,0 +1,195 @@
+(* 'df' command for virtual domains.
+
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+
+   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., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+   Support for Master Boot Record partition scheme.
+*)
+
+open Printf
+open Unix
+open ExtList
+
+open Virt_df_gettext.Gettext
+open Virt_df
+
+let sector_size = 512
+let sector_size64 = 512L
+
+(* Maximum number of extended partitions possible. *)
+let max_extended_partitions = 100
+
+(* Device representing a single partition.  It just acts as an offset
+ * into the underlying device.
+ *
+ * Notes:
+ * (1) 'start'/'size' are measured in sectors.
+ * (2) 'partno' is the partition number, starting at 1
+ *     (cf. /dev/hda1 is the first partition).
+ * (3) 'dev' is the underlying block device.
+ *)
+class partition_device dev partno start size =
+  let devname = dev#name in
+  let name = sprintf "%s%d" devname partno in
+  let start = start *^ sector_size64 in
+  let size = size *^ sector_size64 in
+object (self)
+  inherit device
+  method name = name
+  method size = size
+  method read offset len =
+    if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then
+      invalid_arg (
+       sprintf "%s: tried to read outside partition boundaries (%Ld/%d/%Ld)"
+         name offset len size
+      );
+    dev#read (start+^offset) len
+end
+
+(** Probe the
+    {{:http://en.wikipedia.org/wiki/Master_boot_record}master boot record}
+    (if it is one) and read the partitions.
+
+    @raise Not_found if it is not an MBR.
+ *)
+let rec probe_mbr (dev : device) =
+  (* Adjust size to sectors. *)
+  let size = dev#size /^ sector_size64 in
+
+  (* Read the first sector. *)
+  let bits =
+    try dev#read_bitstring 0L sector_size
+    with exn -> raise Not_found in
+
+  (* Does this match a likely-looking MBR? *)
+  bitmatch bits with
+  | padding : 3568 : bitstring;                (* padding to byte offset 446 *)
+    part0 : 128 : bitstring;           (* partitions *)
+    part1 : 128 : bitstring;
+    part2 : 128 : bitstring;
+    part3 : 128 : bitstring;
+    0x55 : 8; 0xAA : 8 ->              (* MBR signature *)
+
+      (* Parse the partition table entries. *)
+      let primaries =
+       List.mapi (parse_mbr_entry dev) [part0;part1;part2;part3] in
+
+(*
+      (* Read extended partition data. *)
+      let extendeds = List.map (
+       function
+       | { part_type = 0x05 } as part ->
+           probe_extended_partition
+             max_extended_partitions fd part part.part_lba_start
+       | part -> []
+      ) primaries in
+      let extendeds = List.concat extendeds in
+      primaries @ extendeds
+*)
+      { parts_name = "MBR"; parts = primaries }
+
+  | _ ->
+      raise Not_found                  (* not an MBR *)
+
+(* Parse a single partition table entry.  See the table here:
+ * http://en.wikipedia.org/wiki/Master_boot_record
+ *)
+and parse_mbr_entry dev i bits =
+  bitmatch bits with
+  | 0l : 32; 0l : 32; 0l : 32; 0l : 32 ->
+    { part_status = NullEntry; part_type = 0;
+      part_dev = null_device; part_content = `Unknown }
+
+  | 0 : 8; first_chs : 24;
+    part_type : 8; last_chs : 24;
+    first_lba : 32 : unsigned, littleendian;
+    part_size : 32 : unsigned, littleendian ->
+    make_mbr_entry Nonbootable dev (i+1) part_type first_lba part_size
+
+  | 0x80 : 8; first_chs : 24;
+    part_type : 8; last_chs : 24;
+    first_lba : 32 : unsigned, littleendian;
+    part_size : 32 : unsigned, littleendian ->
+    make_mbr_entry Bootable dev (i+1) part_type first_lba part_size
+
+  | _ ->
+      { part_status = Malformed; part_type = 0;
+       part_dev = null_device; part_content = `Unknown }
+
+and make_mbr_entry part_status dev partno part_type first_lba part_size =
+  let first_lba = uint64_of_int32 first_lba in
+  let part_size = uint64_of_int32 part_size in
+  eprintf "first_lba = %Lx\n" first_lba;
+  eprintf "part_size = %Lx\n" part_size;
+  { part_status = part_status;
+    part_type = part_type;
+    part_dev = new partition_device dev partno first_lba part_size;
+    part_content = `Unknown }
+
+(*
+This code worked previously, but now needs some love ...
+XXX
+
+(* Probe an extended partition. *)
+and probe_extended_partition max fd epart sect =
+  if max > 0 then (
+    (* Offset of the first EBR. *)
+    let ebr_offs = sect *^ sector_size in
+    (* EBR Signature? *)
+    LargeFile.lseek fd (ebr_offs +^ 510L) SEEK_SET;
+    let str = String.create 2 in
+    if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then
+      [] (* Not EBR *)
+    else (
+      (* Read the extended partition table entries (just 2 of them). *)
+      LargeFile.lseek fd (ebr_offs +^ 446L) SEEK_SET;
+      let str = String.create 32 in
+      if read fd str 0 32 <> 32 then
+       failwith (s_ "error reading extended partition")
+      else (
+       (* Extract partitions from the data. *)
+       let part1, part2 =
+         match List.map (get_partition str) [ 0; 16 ] with
+         | [p1;p2] -> p1,p2
+         | _ -> failwith (s_ "probe_extended_partition: internal error") in
+       (* First partition entry has offset to the start of this partition. *)
+       let part1 = { part1 with
+                       part_lba_start = sect +^ part1.part_lba_start } in
+       (* Second partition entry is zeroes if end of list, otherwise points
+        * to the next partition.
+        *)
+       if part2.part_status = NullEntry then
+         [part1]
+       else
+         part1 :: probe_extended_partition
+                    (max-1) fd epart (sect +^ part2.part_lba_start)
+      )
+    )
+  )
+  else []
+*)
+
+(* Ugh, fake a UInt32 -> UInt64 conversion without sign extension, until
+ * we get working UInt32/UInt64 modules in extlib.
+ *)
+and uint64_of_int32 u32 =
+  let i64 = Int64.of_int32 u32 in
+  if u32 >= 0l then i64
+  else Int64.add i64 0x1_0000_0000_L
+
+(* Register with main code. *)
+let () = partition_type_register "MBR" probe_mbr