- let major, minor, release =
- let v, _ = Libvirt.get_version () in
- v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
- printf "libvirt %d.%d.%d\n" major minor release;
- exit 0
- in
-
- let test_mode filename =
- test_files := filename :: !test_files
- in
-
- let argspec = Arg.align [
- "-a", Arg.Set all,
- " " ^ s_ "Show all domains (default: only active domains)";
- "--all", Arg.Set all,
- " " ^ s_ "Show all domains (default: only active domains)";
- "-c", Arg.String set_uri,
- "uri " ^ s_ "Connect to URI (default: Xen)";
- "--connect", Arg.String set_uri,
- "uri " ^ s_ "Connect to URI (default: Xen)";
- "-h", Arg.Set human,
- " " ^ s_ "Print sizes in human-readable format";
- "--human-readable", Arg.Set human,
- " " ^ s_ "Print sizes in human-readable format";
- "-i", Arg.Set inodes,
- " " ^ s_ "Show inodes instead of blocks";
- "--inodes", Arg.Set inodes,
- " " ^ s_ "Show inodes instead of blocks";
- "-t", Arg.String test_mode,
- "dev" ^ s_ "(Test mode) Display contents of block device or file";
- "--version", Arg.Unit version,
- " " ^ s_ "Display version and exit";
- ] in
-
- let anon_fun str =
- raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in
- let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests
-
-SUMMARY
- virt-df [-options]
-
-OPTIONS" in
-
- Arg.parse argspec anon_fun usage_msg;
-
- let doms : domain list =
- if !test_files = [] then (
- let xmls =
- (* Connect to the hypervisor. *)
- let conn =
- let name = !uri in
- try C.connect_readonly ?name ()
- with
- Libvirt.Virterror err ->
- prerr_endline (Libvirt.Virterror.to_string err);
- (* If non-root and no explicit connection URI, print a warning. *)
- if geteuid () <> 0 && name = None then (
- print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root");
- );
- 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.
- *)
- xmls in
-
- (* Grr.. Need to use a library which has XPATH support (or cduce). *)
- List.map (
- fun xml ->
- let nodes, domain_attrs =
- match xml with
- | Xml.Element ("domain", attrs, children) -> children, attrs
- | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in
-
- let domid =
- try Some (int_of_string (List.assoc "id" domain_attrs))
- with Not_found -> None in
-
- let rec loop = function
- | [] ->
- failwith (s_ "get_xml_desc returned no <name> node in XML")
- | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
- | Xml.Element ("name", _, _) :: _ ->
- failwith (s_ "get_xml_desc returned strange <name> node")
- | _ :: rest -> loop rest
- in
- let name = loop nodes in
-
- let devices =
- let devices =
- List.filter_map (
- function
- | Xml.Element ("devices", _, devices) -> Some devices
- | _ -> None
- ) nodes in
- List.concat devices in
-
- let rec target_dev_of = function
- | [] -> None
- | Xml.Element ("target", attrs, _) :: rest ->
- (try Some (List.assoc "dev" attrs)
- with Not_found -> target_dev_of rest)
- | _ :: rest -> target_dev_of rest
- in
-
- let rec source_file_of = function
- | [] -> None
- | Xml.Element ("source", attrs, _) :: rest ->
- (try Some (List.assoc "file" attrs)
- with Not_found -> source_file_of rest)
- | _ :: rest -> source_file_of rest
- in
-
- let rec source_dev_of = function
- | [] -> None
- | Xml.Element ("source", attrs, _) :: rest ->
- (try Some (List.assoc "dev" attrs)
- with Not_found -> source_dev_of rest)
- | _ :: rest -> source_dev_of rest
- in
-
- let disks =
- List.filter_map (
- function
- | Xml.Element ("disk", attrs, children) ->
- let typ =
- try Some (List.assoc "type" attrs)
- with Not_found -> None in
- let device =
- try Some (List.assoc "device" attrs)
- with Not_found -> None in
- let source =
- match source_file_of children with
- | (Some _) as source -> source
- | None -> source_dev_of children in
- let target = target_dev_of children in
-
- (* We only care about devices where we have
- * source and target. Ignore CD-ROM devices.
- *)
- (match source, target, device with
- | _, _, Some "cdrom" -> None (* ignore *)
- | Some source, Some target, Some device ->
- (* Try to create a 'device' object for this
- * device. If it fails, print a warning
- * and ignore the device.
- *)
- (try
- let dev = new block_device source in
- Some {
- d_type = typ; d_device = device;
- d_source = source; d_target = target;
- d_dev = dev; d_content = `Unknown
- }
- with
- Unix_error (err, func, param) ->
- eprintf "%s:%s: %s" func param (error_message err);
- None
- )
- | _ -> None (* ignore anything else *)
- )
-
- | _ -> None
- ) devices in
-
- { dom_name = name; dom_id = domid; dom_disks = disks }
- ) xmls
- ) else (
- (* In test mode (-t option) the user can pass one or more
- * block devices or filenames (containing partitions/filesystems/etc)
- * which we use for testing virt-df itself. We create fake domains
- * from these.
- *)
- List.map (
- fun filename ->
- {
- dom_name = filename; dom_id = None;
- dom_disks = [
- {
- d_type = Some "disk"; d_device = "disk";
- d_source = filename; d_target = "hda";
- d_dev = new block_device filename; d_content = `Unknown;
- }
- ]
- }
- ) !test_files
- ) in
-
- (* HOF to map over disks. *)
- let map_over_disks doms f =
- List.map (
- fun ({ dom_disks = disks } as dom) ->
- let disks = List.map f disks in
- { dom with dom_disks = disks }
- ) doms