module C = Libvirt.Connect
module D = Libvirt.Domain
+open Int63.Operators
+
open Virt_df_gettext.Gettext
open Virt_df
-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 disk_block_size = ~^512
+
+(* A libvirt-backed block device. *)
+class libvirt_device dom name path blocksize =
+ (* Size is never really used. *)
+ let size = ~^0 in
+object (self)
+ inherit Diskimage.device
+ method read offset len =
+ let offset = Int63.to_int64 offset in
+ let len = Int63.to_int len in
+ let str = String.make len '\000' in
+ ignore (D.block_peek dom path offset len str 0);
+ str
+ method size = size
+ method name = name
+ method blocksize = blocksize
+ method map_block _ = []
+ method contiguous offset = size -^ offset
+ method close () = ()
+ initializer
+ (* Check that access is possible - throws a virterror if not. *)
+ D.block_peek dom path 0L 0 "" 0
+end
let () =
(* Command line argument parsing. *)
let set_uri = function "" -> uri := None | u -> uri := Some u in
let version () =
- printf "virt-df %s\n" (Libvirt_version.version);
+ printf "virt-df %s\n" Virt_df_version.version;
let major, minor, release =
let v, _ = Libvirt.get_version () in
"--all", Arg.Set all,
" " ^ s_ "Show all domains (default: only active domains)";
"-c", Arg.String set_uri,
- "uri " ^ s_ "Connect to URI (default: Xen)";
+ "uri " ^ s_ "Connect to URI";
"--connect", Arg.String set_uri,
- "uri " ^ s_ "Connect to URI (default: Xen)";
+ "uri " ^ s_ "Connect to URI";
"--csv", Arg.Set csv_mode,
" " ^ s_ "Write results in CSV format";
"--debug", Arg.Set Diskimage.debug,
csv_write stdout
in
- (* name target dev_path *)
- let doms : (string * (string * string) list) list =
+ let doms =
if !test_files = [] then (
let xmls =
(* Connect to the hypervisor. *)
let conn =
let name = !uri in
- try C.connect_readonly ?name ()
+ try C.connect ?name ()
with
Libvirt.Virterror err ->
prerr_endline (Libvirt.Virterror.to_string err);
);
exit 1 in
- (* Get the list of active & inactive domains. *)
- let doms =
- let nr_active_doms = C.num_of_domains conn in
- let active_doms =
- Array.to_list (C.list_domains conn nr_active_doms) in
- let active_doms =
- List.map (D.lookup_by_id conn) active_doms in
- if not !all then
- active_doms
- else (
- let nr_inactive_doms = C.num_of_defined_domains conn in
- let inactive_doms =
- Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
- let inactive_doms =
- List.map (D.lookup_by_name conn) inactive_doms in
- active_doms @ inactive_doms
- ) in
-
- (* Get their XML. *)
- let xmls = List.map D.get_xml_desc doms in
-
- (* Parse the XML. *)
- let xmls = List.map Xml.parse_string xmls in
-
- (* Return just the XML documents - everything else will be closed
- * and freed including the connection to the hypervisor.
- *)
+ let xmls =
+ try
+ (* Get the list of active & inactive domains. *)
+ let doms =
+ let nr_active_doms = C.num_of_domains conn in
+ let active_doms =
+ Array.to_list (C.list_domains conn nr_active_doms) in
+ let active_doms =
+ List.map (D.lookup_by_id conn) active_doms in
+ if not !all then
+ active_doms
+ else (
+ let nr_inactive_doms = C.num_of_defined_domains conn in
+ let inactive_doms =
+ Array.to_list
+ (C.list_defined_domains conn nr_inactive_doms) in
+ let inactive_doms =
+ List.map (D.lookup_by_name conn) inactive_doms in
+ active_doms @ inactive_doms
+ ) in
+
+ (* Get their XML. *)
+ let xmls = List.map (fun dom -> dom, D.get_xml_desc dom) doms in
+
+ (* Parse the XML. *)
+ let xmls = List.map (fun (dom, xml) ->
+ dom, Xml.parse_string xml) xmls in
+
+ xmls
+ with
+ Libvirt.Virterror err ->
+ prerr_endline (Libvirt.Virterror.to_string err);
+ exit 1 in
xmls in
(* Grr.. Need to use a library which has XPATH support (or cduce). *)
List.map (
- fun xml ->
+ fun (dom, xml) ->
let nodes, domain_attrs =
match xml with
| Xml.Element ("domain", attrs, children) -> children, attrs
| _ -> None
) devices in
+ let disks = List.filter_map (
+ fun (name, path) ->
+ try Some (name, new libvirt_device dom name path disk_block_size)
+ with Libvirt.Virterror err ->
+ eprintf "%s: %s\n" name (Libvirt.Virterror.to_string err);
+ None
+ ) disks in
+
name, disks
) xmls
) else (
* which we use for testing virt-df itself. We create fake domains
* from these.
*)
- List.map (
+ List.filter_map (
fun filename ->
- filename, ["hda", filename]
+ try Some (filename,
+ ["hda",
+ new Diskimage.block_device filename disk_block_size])
+ with Unix.Unix_error (err, func, param) ->
+ eprintf "%s:%s: %s\n" func param (Unix.error_message err);
+ None
) !test_files
) in
(* Convert these to Diskimage library 'machine's. *)
- let machines = List.filter_map (
- fun (name, disks) ->
- try Some (Diskimage.open_machine name disks)
- with Unix.Unix_error (err, func, param) ->
- eprintf "%s:%s: %s" func param (Unix.error_message err);
- None
+ let machines = List.map (
+ fun (name, disks) -> Diskimage.open_machine_from_devices name disks
) doms in
(* Scan them. *)
csv_write [ "Filesystem"; total; used; avail; "Type" ] in
let printable_size bytes =
- if bytes < 1024L *^ 1024L then
- sprintf "%Ld bytes" bytes
- else if bytes < 1024L *^ 1024L *^ 1024L then
- sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
+ if bytes < ~^1024 *^ ~^1024 then
+ sprintf "%s bytes" (Int63.to_string bytes)
+ else if bytes < ~^1024 *^ ~^1024 *^ ~^1024 then
+ sprintf "%.1f MiB" (Int63.to_float (bytes /^ ~^1024) /. 1024.)
else
- sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
+ sprintf "%.1f GiB" (Int63.to_float (bytes /^ ~^1024 /^ ~^1024) /. 1024.)
in
(* HOF to iterate over filesystems. *)
printf "%-32s " name;
let {
- Diskimage.fs_plugin_id = fs_plugin_id;
- fs_block_size = fs_block_size;
+ Diskimage.fs_blocksize = fs_blocksize;
fs_blocks_total = fs_blocks_total;
fs_is_swap = fs_is_swap;
fs_blocks_reserved = fs_blocks_reserved;
fs_inodes_used = fs_inodes_used
} = fs in
- let fs_name = Diskimage.name_of_filesystem fs_plugin_id in
+ let fs_name = Diskimage.name_of_filesystem fs in
if fs_is_swap then (
(* Swap partition. *)
if not !human then
- printf "%10Ld %s\n"
- (fs_block_size *^ fs_blocks_total /^ 1024L) fs_name
+ printf "%10s %s\n"
+ (Int63.to_string (fs_blocksize *^ fs_blocks_total /^ ~^1024))
+ fs_name
else
printf "%10s %s\n"
- (printable_size (fs_block_size *^ fs_blocks_total)) fs_name
+ (printable_size (fs_blocksize *^ fs_blocks_total))
+ fs_name
) else (
(* Ordinary filesystem. *)
if not !inodes then ( (* Block display. *)
(* 'df' doesn't count the restricted blocks. *)
let blocks_total = fs_blocks_total -^ fs_blocks_reserved in
let blocks_avail = fs_blocks_avail -^ fs_blocks_reserved in
- let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
+ let blocks_avail = if blocks_avail < ~^0 then ~^0 else blocks_avail in
if not !human then ( (* Display 1K blocks. *)
- printf "%10Ld %10Ld %10Ld %s\n"
- (blocks_total *^ fs_block_size /^ 1024L)
- (fs_blocks_used *^ fs_block_size /^ 1024L)
- (blocks_avail *^ fs_block_size /^ 1024L)
+ printf "%10s %10s %10s %s\n"
+ (Int63.to_string (blocks_total *^ fs_blocksize /^ ~^1024))
+ (Int63.to_string (fs_blocks_used *^ fs_blocksize /^ ~^1024))
+ (Int63.to_string (blocks_avail *^ fs_blocksize /^ ~^1024))
fs_name
) else ( (* Human-readable blocks. *)
printf "%10s %10s %10s %s\n"
- (printable_size (blocks_total *^ fs_block_size))
- (printable_size (fs_blocks_used *^ fs_block_size))
- (printable_size (blocks_avail *^ fs_block_size))
+ (printable_size (blocks_total *^ fs_blocksize))
+ (printable_size (fs_blocks_used *^ fs_blocksize))
+ (printable_size (blocks_avail *^ fs_blocksize))
fs_name
)
) else ( (* Inodes display. *)
- printf "%10Ld %10Ld %10Ld %s\n"
- fs_inodes_total fs_inodes_used fs_inodes_avail
+ printf "%10s %10s %10s %s\n"
+ (Int63.to_string fs_inodes_total)
+ (Int63.to_string fs_inodes_used)
+ (Int63.to_string fs_inodes_avail)
fs_name
)
)
let name = printable_name machine ?disk ?partno dev in
let {
- Diskimage.fs_plugin_id = fs_plugin_id;
- fs_block_size = fs_block_size;
+ Diskimage.fs_blocksize = fs_blocksize;
fs_blocks_total = fs_blocks_total;
fs_is_swap = fs_is_swap;
fs_blocks_reserved = fs_blocks_reserved;
fs_inodes_used = fs_inodes_used
} = fs in
- let fs_name = Diskimage.name_of_filesystem fs_plugin_id in
+ let fs_name = Diskimage.name_of_filesystem fs in
let row =
if fs_is_swap then
(* Swap partition. *)
- [ Int64.to_string (fs_block_size *^ fs_blocks_total /^ 1024L);
+ [ Int63.to_string (fs_blocksize *^ fs_blocks_total /^ ~^1024);
""; "" ]
else (
(* Ordinary filesystem. *)
- if not !inodes then ( (* Block display. *)
+ if not !inodes then ( (* 1K block display. *)
(* 'df' doesn't count the restricted blocks. *)
let blocks_total = fs_blocks_total -^ fs_blocks_reserved in
let blocks_avail = fs_blocks_avail -^ fs_blocks_reserved in
- let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
+ let blocks_avail = if blocks_avail < ~^0 then ~^0 else blocks_avail in
- [ Int64.to_string (blocks_total *^ fs_block_size /^ 1024L);
- Int64.to_string (fs_blocks_used *^ fs_block_size /^ 1024L);
- Int64.to_string (blocks_avail *^ fs_block_size /^ 1024L) ]
+ [ Int63.to_string (blocks_total *^ fs_blocksize /^ ~^1024);
+ Int63.to_string (fs_blocks_used *^ fs_blocksize /^ ~^1024);
+ Int63.to_string (blocks_avail *^ fs_blocksize /^ ~^1024) ]
) else ( (* Inodes display. *)
- [ Int64.to_string fs_inodes_total;
- Int64.to_string fs_inodes_used;
- Int64.to_string fs_inodes_avail ]
+ [ Int63.to_string fs_inodes_total;
+ Int63.to_string fs_inodes_used;
+ Int63.to_string fs_inodes_avail ]
)
) in
git.annexia.org / virt-df.git / blobdiff