Move main code to virt_df_main.ml and provide explicit interface virt_df.mli

4 files changed, 575 insertions, 473 deletions

diff --git a/virt-df/.depend b/virt-df/.depend
index 5aa8cb7..aad2cf0 100644
--- a/virt-df/.depend
+++ b/virt-df/.depend
@@ -1,20 +1,20 @@
-virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmo \
+virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmi \
     /usr/lib64/ocaml/bitmatch/bitmatch.cmi 
 virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx \
     /usr/lib64/ocaml/bitmatch/bitmatch.cmi 
-virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmo \
+virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmi \
     /usr/lib64/ocaml/bitmatch/bitmatch.cmi 
 virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx \
     /usr/lib64/ocaml/bitmatch/bitmatch.cmi 
-virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmo 
+virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmi 
 virt_df_lvm2.cmx: virt_df_gettext.cmx virt_df.cmx 
-virt_df_main.cmo: virt_df.cmo 
-virt_df_main.cmx: virt_df.cmx 
-virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmo \
+virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi \
+    ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi 
+virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx \
+    ../libvirt/libvirt_version.cmx ../libvirt/libvirt.cmx 
+virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmi \
     /usr/lib64/ocaml/bitmatch/bitmatch.cmi 
 virt_df_mbr.cmx: virt_df_gettext.cmx virt_df.cmx \
     /usr/lib64/ocaml/bitmatch/bitmatch.cmi 
-virt_df.cmo: virt_df_gettext.cmo ../libvirt/libvirt_version.cmi \
-    ../libvirt/libvirt.cmi 
-virt_df.cmx: virt_df_gettext.cmx ../libvirt/libvirt_version.cmx \
-    ../libvirt/libvirt.cmx 
+virt_df.cmo: virt_df_gettext.cmo virt_df.cmi 
+virt_df.cmx: virt_df_gettext.cmx virt_df.cmi 
diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml
index b972837..c61f6df 100644
--- a/virt-df/virt_df.ml
+++ b/virt-df/virt_df.ml
@@ -23,79 +23,24 @@ open Unix
 
 open Virt_df_gettext.Gettext
 
-module C = Libvirt.Connect
-module D = Libvirt.Domain
+let debug = true     (* If true emit lots of debugging information. *)
 
-(* If set to true, then emit lots of debugging information. *)
-let debug = true
-
-(* Int32 infix operators for convenience. *)
 let ( +* ) = Int32.add
 let ( -* ) = Int32.sub
 let ( ** ) = Int32.mul
 let ( /* ) = Int32.div
 
-(* 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 uri = ref None
+let inodes = ref false
+let human = ref false
+let all = ref false
+let test_files = ref []
 
-(* 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
@@ -123,7 +68,7 @@ object (self)
   method name = filename
 end
 
-(* A null device.  Any attempt to read generates an error. *)
+(* The null device.  Any attempt to read generates an error. *)
 let null_device : device =
 object
   inherit device
@@ -132,8 +77,6 @@ object
   method name = "null"
 end
 
-(* Domains and candidate guest block devices. *)
-
 type domain = {
   dom_name : string;			(* Domain name. *)
   dom_id : int option;			(* Domain ID (if running). *)
@@ -262,398 +205,3 @@ 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. *)
-  let set_uri = function "" -> uri := None | u -> uri := Some u in
-
-  let version () =
-    printf "virt-df %s\n" (Libvirt_version.version);
-
-    let major, minor, release =
-      let v, _ = Libvirt.get_version () in
-      v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
-    printf "libvirt %d.%d.%d\n" major minor release;
-    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)";
-    "--all", Arg.Set all,
-      " " ^ s_ "Show all domains (default: only active domains)";
-    "-c", Arg.String set_uri,
-      "uri " ^ s_ "Connect to URI (default: Xen)";
-    "--connect", Arg.String set_uri,
-      "uri " ^ s_ "Connect to URI (default: Xen)";
-    "-h", Arg.Set human,
-      " " ^ s_ "Print sizes in human-readable format";
-    "--human-readable", Arg.Set human,
-      " " ^ s_ "Print sizes in human-readable format";
-    "-i", Arg.Set inodes,
-      " " ^ 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
-
-  let anon_fun str =
-    raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in
-  let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests
-
-SUMMARY
-  virt-df [-options]
-
-OPTIONS" in
-
-  Arg.parse argspec anon_fun usage_msg;
-
-  let doms : domain list =
-    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 ("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
-	    ) 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 () =
-    let total, used, avail =
-      match !inodes, !human with
-      | false, false -> s_ "1K-blocks", s_ "Used", s_ "Available"
-      | false, true -> s_ "Size", s_ "Used", s_ "Available"
-      | true, _ -> s_ "Inodes", s_ "IUse", s_ "IFree" in
-    printf "%-20s %10s %10s %10s %s\n%!"
-      (s_ "Filesystem") total used avail (s_ "Type") in
-
-  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.mli b/virt-df/virt_df.mli
new file mode 100644
index 0000000..1b3f6ca
--- /dev/null
+++ b/virt-df/virt_df.mli
@@ -0,0 +1,181 @@
+(** 'df' command for virtual domains. *)
+(* (C) Copyright 2007-2008 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.
+ *)
+
+(* This module (Virt_df) contains functions and values which are
+ * used throughout the plug-ins and main code.
+ *)
+
+val debug : bool
+(** If true, emit logs of debugging information to stderr. *)
+
+val ( +* ) : int32 -> int32 -> int32
+val ( -* ) : int32 -> int32 -> int32
+val ( ** ) : int32 -> int32 -> int32
+val ( /* ) : int32 -> int32 -> int32
+val ( +^ ) : int64 -> int64 -> int64
+val ( -^ ) : int64 -> int64 -> int64
+val ( *^ ) : int64 -> int64 -> int64
+val ( /^ ) : int64 -> int64 -> int64
+(** int32 and int64 infix operators for convenience. *)
+
+val uri : string option ref		(** Hypervisor/libvirt URI. *)
+val inodes : bool ref			(** Display inodes. *)
+val human : bool ref			(** Display human-readable. *)
+val all : bool ref			(** Show all or just active domains. *)
+val test_files : string list ref	(** In test mode (-t) list of files. *)
+(** State of command line arguments. *)
+
+(**
+   {2 Domain/device model}
+
+   The "domain/device model" that we currently understand looks
+   like this:
+
+{v
+domains
+  |
+  \--- host partitions / disk image files
+         ||
+       guest block devices
+         |
+         +--> guest partitions (eg. using MBR)
+         |      |
+         \-(1)->+--- filesystems (eg. ext3)
+                |
+                \--- PVs for LVM
+                       |||
+                     VGs and LVs
+v}
+    
+   (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.
+*)
+
+class virtual device :
+  object
+    method virtual name : string
+    method virtual read : int64 -> int -> string
+    method read_bitstring : int64 -> int -> string * int * int
+    method virtual size : int64
+  end
+  (**
+     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 block_device :
+  string ->
+  object
+    method name : string
+    method read : int64 -> int -> string
+    method read_bitstring : int64 -> int -> string * int * int
+    method size : int64
+  end
+    (** A concrete device which just direct-maps a file or /dev device. *)
+
+val null_device : device
+    (** The null device.  Any attempt to read generates an error. *)
+
+type domain = {
+  dom_name : string;			(** Domain name. *)
+  dom_id : int option;			(** Domain ID (if running). *)
+  dom_disks : disk list;		(** Domain disks. *)
+}
+and disk = {
+  d_type : string option;		(** The <disk type=...> *)
+  d_device : string;			(** The <disk device=...> (eg "disk") *)
+  d_source : string;			(** The <source file=... or dev> *)
+  d_target : string;			(** The <target dev=...> (eg "hda") *)
+  d_dev : device;			(** Disk device. *)
+  d_content : disk_content;		(** What's on it. *)
+}
+and disk_content =
+    [ `Filesystem of filesystem		(** Contains a direct filesystem. *)
+    | `Partitions of partitions		(** Contains partitions. *)
+    | `PhysicalVolume of unit		(** Contains an LVM PV. *)
+    | `Unknown				(** Not probed or unknown. *)
+    ]
+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 filesystem type. *)
+  part_dev : device;			(** Partition device. *)
+  part_content : partition_content;	(** What's on it. *)
+}
+and partition_status = Bootable | Nonbootable | Malformed | NullEntry
+and partition_content =
+    [ `Filesystem of filesystem		(** Filesystem. *)
+    | `PhysicalVolume of unit		(** Contains an LVM PV. *)
+    | `Unknown				(** Not probed or unknown. *)
+    ]
+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. *)
+  fs_inodes_total : int64;		(** Total inodes. *)
+  fs_inodes_reserved : int64;		(** Inodes reserved for super-user. *)
+  fs_inodes_avail : int64;		(** Inodes free (available). *)
+  fs_inodes_used : int64;		(** Inodes in use. *)
+}
+
+val string_of_partition : partition -> string
+val string_of_filesystem : filesystem -> string
+(** Convert a partition or filesystem struct to a string (for debugging). *)
+
+val partition_type_register : string -> (device -> partitions) -> unit
+(** Register a partition probing plugin. *)
+
+val probe_for_partitions : device -> partitions option
+(** Do a partition probe on a device.  Returns [Some partitions] or [None]. *)
+
+val filesystem_type_register : string -> (device -> filesystem) -> unit
+(** Register a filesystem probing plugin. *)
+
+val probe_for_filesystems : device -> filesystem option
+(** Do a filesystem probe on a device.  Returns [Some filesystem] or [None]. *)
diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml
index 1359b28..9504785 100644
--- a/virt-df/virt_df_main.ml
+++ b/virt-df/virt_df_main.ml
@@ -17,7 +17,380 @@
    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 ()
+open Printf
+open ExtList
+open Unix
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+
+open Virt_df_gettext.Gettext
+open Virt_df
+
+let () =
+  (* Command line argument parsing. *)
+  let set_uri = function "" -> uri := None | u -> uri := Some u in
+
+  let version () =
+    printf "virt-df %s\n" (Libvirt_version.version);
+
+    let major, minor, release =
+      let v, _ = Libvirt.get_version () in
+      v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
+    printf "libvirt %d.%d.%d\n" major minor release;
+    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)";
+    "--all", Arg.Set all,
+      " " ^ s_ "Show all domains (default: only active domains)";
+    "-c", Arg.String set_uri,
+      "uri " ^ s_ "Connect to URI (default: Xen)";
+    "--connect", Arg.String set_uri,
+      "uri " ^ s_ "Connect to URI (default: Xen)";
+    "-h", Arg.Set human,
+      " " ^ s_ "Print sizes in human-readable format";
+    "--human-readable", Arg.Set human,
+      " " ^ s_ "Print sizes in human-readable format";
+    "-i", Arg.Set inodes,
+      " " ^ 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
+
+  let anon_fun str =
+    raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in
+  let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests
+
+SUMMARY
+  virt-df [-options]
+
+OPTIONS" in
+
+  Arg.parse argspec anon_fun usage_msg;
+
+  let doms : domain list =
+    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 ("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
+	    ) 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 () =
+    let total, used, avail =
+      match !inodes, !human with
+      | false, false -> s_ "1K-blocks", s_ "Used", s_ "Available"
+      | false, true -> s_ "Size", s_ "Used", s_ "Available"
+      | true, _ -> s_ "Inodes", s_ "IUse", s_ "IFree" in
+    printf "%-20s %10s %10s %10s %s\n%!"
+      (s_ "Filesystem") total used avail (s_ "Type") in
+
+  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