X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=virt-df%2Fvirt_df.ml;h=c02c8e3d19b4f38f67bc4da523d3088bf1897e0a;hb=0dc5575b79e4d5e003966eaaeb4d0a6a6e8802ed;hp=1cd0617cfeb4f869bc843cdcb68426a0e8d4aa58;hpb=be71668a1a4b6c87da3e82458ca97a199a24aa32;p=virt-top.git diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index 1cd0617..c02c8e3 100644 --- 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,7 +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 : filesystem list; (* Domain LV filesystems. *) + dom_lv_filesystems : + (lv * filesystem) list; (* Domain LV filesystems. *) } and disk = { (* From the XML ... *) @@ -98,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. *) @@ -117,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). *) @@ -135,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 } = @@ -151,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 = @@ -158,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 -> @@ -166,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 } -> @@ -183,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 -> @@ -191,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 -> @@ -207,18 +249,19 @@ 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 @@ -244,3 +287,7 @@ let group_by ?(cmp = Pervasives.compare) 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 []