Complete rewrite of virt-df:

  - Uses pa_bitmatch for robust parsing of disk structures.
  - Completely modularized.

6 files changed, 874 insertions, 490 deletions

diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml
index 4fbc706..b972837 100644
--- a/virt-df/virt_df.ml
+++ b/virt-df/virt_df.ml
@@ -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)
+*)
diff --git a/virt-df/virt_df_ext2.ml b/virt-df/virt_df_ext2.ml
index 1acd855..0ea8a25 100644
--- a/virt-df/virt_df_ext2.ml
+++ b/virt-df/virt_df_ext2.ml
@@ -21,46 +21,82 @@
 
 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
diff --git a/virt-df/virt_df_linux_swap.ml b/virt-df/virt_df_linux_swap.ml
index 04e22b9..ad56149 100644
--- a/virt-df/virt_df_linux_swap.ml
+++ b/virt-df/virt_df_linux_swap.ml
@@ -21,22 +21,34 @@
 *)
 
 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
diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml
index d01a5a8..a79ec7f 100644
--- a/virt-df/virt_df_lvm2.ml
+++ b/virt-df/virt_df_lvm2.ml
@@ -22,18 +22,11 @@
 
 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
diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml
index bc4096b..1359b28 100755..100644
--- a/virt-df/virt_df_main.ml
+++ b/virt-df/virt_df_main.ml
@@ -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
index 0000000..b9a6cb7
--- /dev/null
+++ b/virt-df/virt_df_mbr.ml
@@ -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