(* '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 *) d_device : string; (* The (eg "disk") *) d_source : string; (* The *) d_target : string; (* The (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 []