--- /dev/null
+# $Id: Makefile.in,v 1.6 2007/08/23 11:09:19 rjones Exp $
+
+PACKAGE := @PACKAGE_NAME@
+VERSION := @PACKAGE_VERSION@
+
+INSTALL := @INSTALL@
+HAVE_PERLDOC := @HAVE_PERLDOC@
+
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+bindir = @bindir@
+
+pkg_xml_light = @pkg_xml_light@
+
+OCAMLCPACKAGES := -package unix,extlib,xml-light
+
+OBJS := virt_df.cmo
+XOBJS := $(OBJS:.cmo=.cmx)
+
+OCAMLCPACKAGES += -I ../libvirt
+OCAMLCFLAGS := -g -w s
+OCAMLCLIBS := -linkpkg
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS := -w s
+OCAMLOPTLIBS := $(OCAMLCLIBS)
+
+export LIBRARY_PATH=../libvirt
+export LD_LIBRARY_PATH=../libvirt
+
+BYTE_TARGETS := virt-df
+OPT_TARGETS := virt-df.opt
+
+#ifeq ($(HAVE_PERLDOC),perldoc)
+#BYTE_TARGETS += virt-top.1 virt-top.txt
+#endif
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+virt-df: $(OBJS)
+ ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+ ../libvirt/mllibvirt.cma -o $@ $^
+
+virt-df.opt: $(XOBJS)
+ ocamlfind ocamlopt \
+ $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+ ../libvirt/mllibvirt.cmxa -cclib -lncurses -o $@ $^
+
+# Manual page.
+#ifeq ($(HAVE_PERLDOC),perldoc)
+#virt-top.1: virt-top.pod
+# pod2man -c "Virtualization Support" --release "$(PACKAGE)-$(VERSION)" \
+# $< > $@
+#
+#virt-top.txt: virt-top.pod
+# pod2text $< > $@
+#endif
+
+install:
+ if [ -x virt-df.opt ]; then \
+ mkdir -p $(DESTDIR)$(bindir); \
+ $(INSTALL) -m 0755 virt-df.opt $(DESTDIR)$(bindir)/virt-df; \
+ fi
+
+include ../Make.rules
--- /dev/null
+(* 'df' command for virtual domains.
+ * $Id$
+ *)
+
+open Printf
+open ExtList
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module N = Libvirt.Network
+
+let uri = ref None
+
+let () =
+ (* Command line argument parsing. *)
+ let set_uri = function "" -> uri := None | u -> uri := Some u in
+
+ let argspec = Arg.align [
+ "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)";
+ "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)";
+ ] in
+
+ let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in
+ let usage_msg = "virt-df : like 'df', shows disk space used in guests
+
+SUMMARY
+ virt-df [-options]
+
+OPTIONS" in
+
+ Arg.parse argspec anon_fun usage_msg
+
+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 Unix.geteuid () <> 0 && name = None then (
+ print_endline "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
+ 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
+
+(* Parse out the device XML to get the names of disks. *)
+type domain = {
+ dom_name : string; (* Domain name. *)
+ dom_id : int option; (* Domain ID (if running). *)
+ dom_disks : disk list; (* Domain disks. *)
+}
+and disk = {
+ d_type : string option; (* The <disk type=...> *)
+ d_device : string option; (* The <disk device=...> *)
+ d_file : string option; (* The <source file=...> *)
+ d_dev : string option; (* The <target dev=...> *)
+}
+
+let doms : domain list =
+ (* 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 "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 "get_xml_desc returned no <name> node in XML"
+ | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
+ | Xml.Element ("name", _, _) :: _ ->
+ failwith "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 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 file = source_file_of children in
+ let dev = target_dev_of children in
+
+ Some {
+ d_type = typ; d_device = device; d_file = file; d_dev = dev
+ }
+ | _ -> None
+ ) devices in
+
+ { dom_name = name; dom_id = domid; dom_disks = disks }
+ ) xmls
+
+(* Print the domains / devices. *)
+let () =
+ List.iter (
+ fun { dom_name = dom_name; dom_disks = dom_disks } ->
+ printf "%s:\n" dom_name;
+ List.iter (
+ function
+ | { d_file = Some file; d_dev = Some dev } ->
+ printf "\t%s -> %s\n" file dev
+ | _ ->
+ printf "\t(device omitted, missing <source> or <target> in XML\n";
+ ) dom_disks
+ ) doms
git.annexia.org / virt-top.git / commitdiff