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 debug = true (* If true emit lots of debugging information. *)
28 let ( +* ) = Int32.add
29 let ( -* ) = Int32.sub
30 let ( ** ) = Int32.mul
31 let ( /* ) = Int32.div
33 let ( +^ ) = Int64.add
34 let ( -^ ) = Int64.sub
35 let ( *^ ) = Int64.mul
36 let ( /^ ) = Int64.div
39 let inodes = ref false
42 let test_files = ref []
44 class virtual device =
46 method virtual read : int64 -> int -> string
47 method virtual size : int64
48 method virtual name : string
50 (* Helper method to read a chunk of data into a bitstring. *)
51 method read_bitstring offset len =
52 let str = self#read offset len in
56 (* A concrete device which just direct-maps a file or /dev device. *)
57 class block_device filename =
58 let fd = openfile filename [ O_RDONLY ] 0 in
59 let size = (LargeFile.fstat fd).LargeFile.st_size in
62 method read offset len =
63 ignore (LargeFile.lseek fd offset SEEK_SET);
64 let str = String.make len '\000' in
68 method name = filename
71 (* The null device. Any attempt to read generates an error. *)
72 let null_device : device =
75 method read _ _ = assert false
81 dom_name : string; (* Domain name. *)
82 dom_id : int option; (* Domain ID (if running). *)
83 dom_disks : disk list; (* Domain disks. *)
86 (* From the XML ... *)
87 d_type : string option; (* The <disk type=...> *)
88 d_device : string; (* The <disk device=...> (eg "disk") *)
89 d_source : string; (* The <source file=... or dev> *)
90 d_target : string; (* The <target dev=...> (eg "hda") *)
92 (* About the device itself. *)
93 d_dev : device; (* Disk device. *)
94 d_content : disk_content; (* What's on it. *)
97 [ `Unknown (* Not probed or unknown. *)
98 | `Partitions of partitions (* Contains partitions. *)
99 | `Filesystem of filesystem (* Contains a filesystem directly. *)
100 | `PhysicalVolume of unit (* Contains an LVM PV. *)
106 parts_name : string; (* Name of partitioning scheme. *)
107 parts : partition list (* Partitions. *)
110 part_status : partition_status; (* Bootable, etc. *)
111 part_type : int; (* Partition filesystem type. *)
112 part_dev : device; (* Partition device. *)
113 part_content : partition_content; (* What's on it. *)
115 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
116 and partition_content =
117 [ `Unknown (* Not probed or unknown. *)
118 | `Filesystem of filesystem (* Filesystem. *)
119 | `PhysicalVolume of unit (* Contains an LVM PV. *)
122 (* Filesystems (also swap devices). *)
124 fs_name : string; (* Name of filesystem. *)
125 fs_block_size : int64; (* Block size (bytes). *)
126 fs_blocks_total : int64; (* Total blocks. *)
127 fs_is_swap : bool; (* If swap, following not valid. *)
128 fs_blocks_reserved : int64; (* Blocks reserved for super-user. *)
129 fs_blocks_avail : int64; (* Blocks free (available). *)
130 fs_blocks_used : int64; (* Blocks in use. *)
131 fs_inodes_total : int64; (* Total inodes. *)
132 fs_inodes_reserved : int64; (* Inodes reserved for super-user. *)
133 fs_inodes_avail : int64; (* Inodes free (available). *)
134 fs_inodes_used : int64; (* Inodes in use. *)
137 (* Convert partition, filesystem types to printable strings for debugging. *)
138 let string_of_partition
139 { part_status = status; part_type = typ; part_dev = dev } =
140 sprintf "%s: %s partition type %d"
143 | Bootable -> "bootable"
144 | Nonbootable -> "nonbootable"
145 | Malformed -> "malformed"
146 | NullEntry -> "empty")
149 let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
150 if not swap then name
151 else name ^ " [swap]"
153 (* Register a partition scheme. *)
154 let partition_types = ref []
155 let partition_type_register (parts_name : string) probe_fn =
156 partition_types := (parts_name, probe_fn) :: !partition_types
158 (* Probe a device for partitions. Returns [Some parts] or [None]. *)
159 let probe_for_partitions dev =
160 if debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
161 let rec loop = function
163 | (parts_name, probe_fn) :: rest ->
164 try Some (probe_fn dev)
165 with Not_found -> loop rest
167 let r = loop !partition_types in
170 | None -> eprintf "no partitions found on %s\n%!" dev#name
171 | Some { parts_name = name; parts = parts } ->
172 eprintf "found %d %s partitions on %s:\n"
173 (List.length parts) name dev#name;
174 List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts
178 (* Register a filesystem type (or swap). *)
179 let filesystem_types = ref []
180 let filesystem_type_register (fs_name : string) probe_fn =
181 filesystem_types := (fs_name, probe_fn) :: !filesystem_types
183 (* Probe a device for filesystems. Returns [Some fs] or [None]. *)
184 let probe_for_filesystems dev =
185 if debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
186 let rec loop = function
188 | (fs_name, probe_fn) :: rest ->
189 try Some (probe_fn dev)
190 with Not_found -> loop rest
192 let r = loop !filesystem_types in
195 | None -> eprintf "no filesystem found on %s\n%!" dev#name
197 eprintf "found a filesystem on %s:\n" dev#name;
198 eprintf "\t%s\n%!" (string_of_filesystem fs)
202 (* Register a volume management type. *)
204 let lvm_types = ref []
205 let lvm_type_register (lvm_name : string) probe_fn =
206 lvm_types := (lvm_name, probe_fn) :: !lvm_types