+++ /dev/null
-(* '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.
- *)
-
-open Printf
-open ExtList
-open Unix
-
-open Virt_df_gettext.Gettext
-
-let ( +* ) = Int32.add
-let ( -* ) = Int32.sub
-let ( ** ) = Int32.mul
-let ( /* ) = Int32.div
-
-let ( +^ ) = Int64.add
-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
-let all = ref false
-let test_files = ref []
-
-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 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
- inherit device
- method read _ _ = assert false
- method size = 0L
- method name = "null"
-end
-
-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 ... *)
- 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") *)
-
- (* 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 pv (* 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 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 =
- [ `Unknown (* Not probed or unknown. *)
- | `Filesystem of filesystem (* Filesystem. *)
- | `PhysicalVolume of pv (* 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. *)
- 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. *)
-}
-
-(* 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 } =
- 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]"
-
-(* 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 =
- 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 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;
- 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 list_lvs_fn =
- lvm_types := (lvm_name, (probe_fn, list_lvs_fn)) :: !lvm_types
-
-(* 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;
- let rec loop = function
- | [] -> None
- | (lvm_name, (probe_fn, _)) :: rest ->
- try Some (probe_fn lvm_name dev)
- with Not_found -> loop rest
- in
- let r = loop !lvm_types in
- if !debug then (
- match r with
- | None -> eprintf "no PV found on %s\n%!" dev#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 []
git.annexia.org / virt-top.git / blobdiff