1 (* 'df' command for virtual domains.
2 (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
24 open Virt_df_gettext.Gettext
26 let ( +* ) = Int32.add
27 let ( -* ) = Int32.sub
28 let ( ** ) = Int32.mul
29 let ( /* ) = Int32.div
31 let ( +^ ) = Int64.add
32 let ( -^ ) = Int64.sub
33 let ( *^ ) = Int64.mul
34 let ( /^ ) = Int64.div
36 (* Command line arguments. *)
39 let inodes = ref false
42 let test_files = ref []
43 let csv_mode = ref false
45 (* Support for CSV (overridden by virt_df_csv.ml, if present). *)
46 let csv_write = ref None
48 class virtual device =
50 method virtual read : int64 -> int -> string
51 method virtual size : int64
52 method virtual name : string
54 (* Helper method to read a chunk of data into a bitstring. *)
55 method read_bitstring offset len =
56 let str = self#read offset len in
60 (* A concrete device which just direct-maps a file or /dev device. *)
61 class block_device filename =
62 let fd = openfile filename [ O_RDONLY ] 0 in
63 let size = (LargeFile.fstat fd).LargeFile.st_size in
66 method read offset len =
67 ignore (LargeFile.lseek fd offset SEEK_SET);
68 let str = String.make len '\000' in
72 method name = filename
75 (* A linear offset/size from an underlying device. *)
76 class offset_device name start size (dev : device) =
81 method read offset len =
82 if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then
84 sprintf "%s: tried to read outside device boundaries (%Ld/%d/%Ld)"
87 dev#read (start+^offset) len
90 (* The null device. Any attempt to read generates an error. *)
91 let null_device : device =
94 method read _ _ = assert false
100 dom_name : string; (* Domain name. *)
101 dom_id : int option; (* Domain ID (if running). *)
102 dom_disks : disk list; (* Domain disks. *)
104 (lv * filesystem) list; (* Domain LV filesystems. *)
107 (* From the XML ... *)
108 d_type : string option; (* The <disk type=...> *)
109 d_device : string; (* The <disk device=...> (eg "disk") *)
110 d_source : string; (* The <source file=... or dev> *)
111 d_target : string; (* The <target dev=...> (eg "hda") *)
113 (* About the device itself. *)
114 d_dev : device; (* Disk device. *)
115 d_content : disk_content; (* What's on it. *)
118 [ `Unknown (* Not probed or unknown. *)
119 | `Partitions of partitions (* Contains partitions. *)
120 | `Filesystem of filesystem (* Contains a filesystem directly. *)
121 | `PhysicalVolume of pv (* Contains an LVM PV. *)
127 parts_name : string; (* Name of partitioning scheme. *)
128 parts : partition list (* Partitions. *)
131 part_status : partition_status; (* Bootable, etc. *)
132 part_type : int; (* Partition filesystem type. *)
133 part_dev : device; (* Partition device. *)
134 part_content : partition_content; (* What's on it. *)
136 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
137 and partition_content =
138 [ `Unknown (* Not probed or unknown. *)
139 | `Filesystem of filesystem (* Filesystem. *)
140 | `PhysicalVolume of pv (* Contains an LVM PV. *)
143 (* Filesystems (also swap devices). *)
145 fs_name : string; (* Name of filesystem. *)
146 fs_block_size : int64; (* Block size (bytes). *)
147 fs_blocks_total : int64; (* Total blocks. *)
148 fs_is_swap : bool; (* If swap, following not valid. *)
149 fs_blocks_reserved : int64; (* Blocks reserved for super-user. *)
150 fs_blocks_avail : int64; (* Blocks free (available). *)
151 fs_blocks_used : int64; (* Blocks in use. *)
152 fs_inodes_total : int64; (* Total inodes. *)
153 fs_inodes_reserved : int64; (* Inodes reserved for super-user. *)
154 fs_inodes_avail : int64; (* Inodes free (available). *)
155 fs_inodes_used : int64; (* Inodes in use. *)
158 (* Physical volumes. *)
160 lvm_plugin_id : lvm_plugin_id; (* The LVM plug-in. *)
161 pv_uuid : string; (* UUID. *)
164 (* Logical volumes. *)
166 lv_dev : device; (* Logical volume device. *)
169 and lvm_plugin_id = string
171 (* Convert partition, filesystem types to printable strings for debugging. *)
172 let string_of_partition
173 { part_status = status; part_type = typ; part_dev = dev } =
174 sprintf "%s: %s partition type %d"
177 | Bootable -> "bootable"
178 | Nonbootable -> "nonbootable"
179 | Malformed -> "malformed"
180 | NullEntry -> "empty")
183 let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
184 if not swap then name
185 else name ^ " [swap]"
187 (* Convert a UUID (containing '-' chars) to canonical form. *)
188 let canonical_uuid uuid =
189 let uuid' = String.make 32 ' ' in
191 for i = 0 to String.length uuid - 1 do
193 invalid_arg (sprintf (f_ "canonical_uuid: UUID is too long: %s") uuid);
195 if c <> '-' then ( uuid'.[!j] <- c; incr j )
198 invalid_arg (sprintf (f_ "canonical_uuid: invalid UUID: %s") uuid);
201 (* Register a partition scheme. *)
202 let partition_types = ref []
203 let partition_type_register (parts_name : string) probe_fn =
204 partition_types := (parts_name, probe_fn) :: !partition_types
206 (* Probe a device for partitions. Returns [Some parts] or [None]. *)
207 let probe_for_partitions dev =
208 if !debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
209 let rec loop = function
211 | (parts_name, probe_fn) :: rest ->
212 try Some (probe_fn dev)
213 with Not_found -> loop rest
215 let r = loop !partition_types in
218 | None -> eprintf "no partitions found on %s\n%!" dev#name
219 | Some { parts_name = name; parts = parts } ->
220 eprintf "found %d %s partitions on %s:\n"
221 (List.length parts) name dev#name;
222 List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts
226 (* Register a filesystem type (or swap). *)
227 let filesystem_types = ref []
228 let filesystem_type_register (fs_name : string) probe_fn =
229 filesystem_types := (fs_name, probe_fn) :: !filesystem_types
231 (* Probe a device for a filesystem. Returns [Some fs] or [None]. *)
232 let probe_for_filesystem dev =
233 if !debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
234 let rec loop = function
236 | (fs_name, probe_fn) :: rest ->
237 try Some (probe_fn dev)
238 with Not_found -> loop rest
240 let r = loop !filesystem_types in
243 | None -> eprintf "no filesystem found on %s\n%!" dev#name
245 eprintf "found a filesystem on %s:\n" dev#name;
246 eprintf "\t%s\n%!" (string_of_filesystem fs)
250 (* Register a volume management type. *)
251 let lvm_types = ref []
252 let lvm_type_register (lvm_name : string) probe_fn list_lvs_fn =
253 lvm_types := (lvm_name, (probe_fn, list_lvs_fn)) :: !lvm_types
255 (* Probe a device for a PV. Returns [Some lvm_name] or [None]. *)
256 let probe_for_pv dev =
257 if !debug then eprintf "probing if %s is a PV ...\n%!" dev#name;
258 let rec loop = function
260 | (lvm_name, (probe_fn, _)) :: rest ->
261 try Some (probe_fn lvm_name dev)
262 with Not_found -> loop rest
264 let r = loop !lvm_types in
267 | None -> eprintf "no PV found on %s\n%!" dev#name
268 | Some { lvm_plugin_id = name } ->
269 eprintf "%s contains a %s PV\n%!" dev#name name
273 let list_lvs lvm_name devs =
274 let _, list_lvs_fn = List.assoc lvm_name !lvm_types in
277 (*----------------------------------------------------------------------*)
279 (* This version by Isaac Trotts. *)
280 let group_by ?(cmp = Pervasives.compare) ls =
283 (fun acc (day1, x1) ->
286 | (day2, ls2) :: acctl ->
288 then (day1, x1 :: ls2) :: acctl
289 else (day1, [x1]) :: acc)
293 let ls' = List.rev ls' in
294 List.map (fun (x, xs) -> x, List.rev xs) ls'
297 if a < b then a :: range (a+1) b