Updated MANIFEST.

[virt-top.git] / virt-df / virt_df.ml

diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml
index b992e1b..c02c8e3 100644 (file)
--- a/virt-df/virt_df.ml
+++ b/virt-df/virt_df.ml
@@ -23,8 +23,6 @@ open Unix
 
 open Virt_df_gettext.Gettext
 
-let debug = true     (* If true emit lots of debugging information. *)
-
 let ( +* ) = Int32.add
 let ( -* ) = Int32.sub
 let ( ** ) = Int32.mul
@@ -35,6 +33,7 @@ let ( -^ ) = Int64.sub
 let ( *^ ) = Int64.mul
 let ( /^ ) = Int64.div
 
+let debug = ref false
 let uri = ref None
 let inodes = ref false
 let human = ref false
@@ -68,6 +67,21 @@ object (self)
   method name = filename
 end
 
+(* A linear offset/size from an underlying device. *)
+class offset_device name start size (dev : device) =
+object
+  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 device boundaries (%Ld/%d/%Ld)"
+         name offset len size
+      );
+    dev#read (start+^offset) len
+end
+
 (* The null device.  Any attempt to read generates an error. *)
 let null_device : device =
 object
@@ -81,6 +95,8 @@ type domain = {
   dom_name : string;                   (* Domain name. *)
   dom_id : int option;                 (* Domain ID (if running). *)
   dom_disks : disk list;               (* Domain disks. *)
+  dom_lv_filesystems :
+    (lv * filesystem) list;            (* Domain LV filesystems. *)
 }
 and disk = {
   (* From the XML ... *)
@@ -97,7 +113,7 @@ and disk_content =
   [ `Unknown                           (* Not probed or unknown. *)
   | `Partitions of partitions          (* Contains partitions. *)
   | `Filesystem of filesystem          (* Contains a filesystem directly. *)
-  | `PhysicalVolume of string          (* Contains an LVM PV. *)
+  | `PhysicalVolume of pv              (* Contains an LVM PV. *)
   ]
 
 (* Partitions. *)
@@ -116,7 +132,7 @@ and partition_status = Bootable | Nonbootable | Malformed | NullEntry
 and partition_content =
   [ `Unknown                           (* Not probed or unknown. *)
   | `Filesystem of filesystem          (* Filesystem. *)
-  | `PhysicalVolume of string          (* Contains an LVM PV. *)
+  | `PhysicalVolume of pv              (* Contains an LVM PV. *)
   ]
 
 (* Filesystems (also swap devices). *)
@@ -134,6 +150,19 @@ and filesystem = {
   fs_inodes_used : int64;              (* Inodes in use. *)
 }
 
+(* Physical volumes. *)
+and pv = {
+  lvm_plugin_id : lvm_plugin_id;        (* The LVM plug-in. *)
+  pv_uuid : string;                    (* UUID. *)
+}
+
+(* Logical volumes. *)
+and lv = {
+  lv_dev : device;                     (* Logical volume device. *)
+}
+
+and lvm_plugin_id = string
+
 (* Convert partition, filesystem types to printable strings for debugging. *)
 let string_of_partition
     { part_status = status; part_type = typ; part_dev = dev } =
@@ -150,6 +179,20 @@ let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
   if not swap then name
   else name ^ " [swap]"
 
+(* Convert a UUID (containing '-' chars) to canonical form. *)
+let canonical_uuid uuid =
+  let uuid' = String.make 32 ' ' in
+  let j = ref 0 in
+  for i = 0 to String.length uuid - 1 do
+    if !j >= 32 then
+      invalid_arg (sprintf (f_ "canonical_uuid: UUID is too long: %s") uuid);
+    let c = uuid.[i] in
+    if c <> '-' then ( uuid'.[!j] <- c; incr j )
+  done;
+  if !j <> 32 then
+    invalid_arg (sprintf (f_ "canonical_uuid: invalid UUID: %s") uuid);
+  uuid'
+
 (* Register a partition scheme. *)
 let partition_types = ref []
 let partition_type_register (parts_name : string) probe_fn =
@@ -157,7 +200,7 @@ let partition_type_register (parts_name : string) probe_fn =
 
 (* 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;
+  if !debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
   let rec loop = function
     | [] -> None
     | (parts_name, probe_fn) :: rest ->
@@ -165,7 +208,7 @@ let probe_for_partitions dev =
        with Not_found -> loop rest
   in
   let r = loop !partition_types in
-  if debug then (
+  if !debug then (
     match r with
     | None -> eprintf "no partitions found on %s\n%!" dev#name
     | Some { parts_name = name; parts = parts } ->
@@ -182,7 +225,7 @@ let filesystem_type_register (fs_name : string) probe_fn =
 
 (* Probe a device for a filesystem.  Returns [Some fs] or [None]. *)
 let probe_for_filesystem dev =
-  if debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
+  if !debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
   let rec loop = function
     | [] -> None
     | (fs_name, probe_fn) :: rest ->
@@ -190,7 +233,7 @@ let probe_for_filesystem dev =
        with Not_found -> loop rest
   in
   let r = loop !filesystem_types in
-  if debug then (
+  if !debug then (
     match r with
     | None -> eprintf "no filesystem found on %s\n%!" dev#name
     | Some fs ->
@@ -206,17 +249,45 @@ let lvm_type_register (lvm_name : string) probe_fn list_lvs_fn =
 
 (* Probe a device for a PV.  Returns [Some lvm_name] or [None]. *)
 let probe_for_pv dev =
-  if debug then eprintf "probing if %s is a PV ...\n%!" dev#name;
+  if !debug then eprintf "probing if %s is a PV ...\n%!" dev#name;
   let rec loop = function
     | [] -> None
     | (lvm_name, (probe_fn, _)) :: rest ->
-       if probe_fn dev then Some lvm_name else loop rest
+       try Some (probe_fn lvm_name dev)
+       with Not_found -> loop rest
   in
   let r = loop !lvm_types in
-  if debug then (
+  if !debug then (
     match r with
     | None -> eprintf "no PV found on %s\n%!" dev#name
-    | Some lvm_name ->
-       eprintf "%s contains a %s PV\n%!" dev#name lvm_name
+    | Some { lvm_plugin_id = name } ->
+       eprintf "%s contains a %s PV\n%!" dev#name name
   );
   r
+
+let list_lvs lvm_name devs =
+  let _, list_lvs_fn = List.assoc lvm_name !lvm_types in
+  list_lvs_fn devs
+
+(*----------------------------------------------------------------------*)
+
+(* This version by Isaac Trotts. *)
+let group_by ?(cmp = Pervasives.compare) ls =
+  let ls' =
+    List.fold_left
+      (fun acc (day1, x1) ->
+         match acc with
+             [] -> [day1, [x1]]
+           | (day2, ls2) :: acctl ->
+               if cmp day1 day2 = 0
+               then (day1, x1 :: ls2) :: acctl
+               else (day1, [x1]) :: acc)
+      []
+      ls
+  in
+  let ls' = List.rev ls' in
+  List.map (fun (x, xs) -> x, List.rev xs) ls'
+
+let rec range a b =
+  if a < b then a :: range (a+1) b
+  else []