OCaml >= 3.11.0
ocaml-libvirt >= 0.6.1.1 (for virDomainGetCPUStats support)
OCaml curses
+libxml2
Optional:
OCaml gettext
-OCaml xml-light
OCaml Calendar, version 2 is preferred
perldoc
msgfmt
dnl Check support for 64 bit file offsets.
AC_SYS_LARGEFILE
+dnl Check for libxml2 (required).
+PKG_CHECK_MODULES([LIBXML2], [libxml-2.0])
+
dnl Check for basic OCaml environment & findlib.
AC_PROG_OCAML
if test "$OCAMLC" = "no"; then
dnl Check for optional OCaml packages.
AC_CHECK_OCAML_PKG(calendar)
AC_CHECK_OCAML_PKG(gettext)
-AC_CHECK_OCAML_PKG(xml-light)
AM_CONDITIONAL([HAVE_PKG_CALENDAR], [test "x$OCAML_PKG_calendar" != "xno"])
AM_CONDITIONAL([HAVE_PKG_GETTEXT], [test "x$OCAML_PKG_gettext" != "xno"])
-AM_CONDITIONAL([HAVE_PKG_XML_LIGHT],[test "x$OCAML_PKG_xml_light" != "xno"])
dnl Check if ocamlc/ocamlopt -runtime-variant _pic works. It was
dnl added in OCaml >= 4.03, but in theory might be disabled by
-./src/dummy.c
+./src/xml-c.c
./src/opt_calendar.ml
./src/opt_csv.ml
./src/opt_gettext.ml
-./src/opt_xml.ml
./src/redraw.ml
./src/screen.ml
./src/stream_output.ml
./src/types.ml
./src/utils.ml
./src/version.ml
+./src/xml.ml
# OCaml dependencies generated by ../ocaml-dep.sh
collect.cmo : \
+ xml.cmo \
utils.cmi \
types.cmi \
collect.cmi
collect.cmx : \
+ xml.cmx \
utils.cmx \
types.cmx \
collect.cmi
opt_gettext.cmx
opt_gettext.cmo :
opt_gettext.cmx :
-opt_xml.cmo : \
- opt_gettext.cmo \
- collect.cmi
-opt_xml.cmx : \
- opt_gettext.cmx \
- collect.cmx
redraw.cmo : \
utils.cmi \
types.cmi \
utils.cmi :
version.cmo :
version.cmx :
+xml.cmo :
+xml.cmx :
collect.mli \
csv_output.ml \
csv_output.mli \
- dummy.c \
main.ml \
opt_calendar.ml \
opt_gettext.ml \
- opt_xml.ml \
redraw.ml \
redraw.mli \
screen.ml \
utils.ml \
utils.mli \
version.ml \
- virt-top.pod
+ virt-top.pod \
+ xml-c.c \
+ xml.ml
OCAMLPACKAGES = -package unix,curses,str,libvirt
opt_gettext.cmo \
utils.cmo \
types.cmo \
+ xml.cmo \
collect.cmo \
screen.cmo \
redraw.cmo \
csv_output.cmo \
stream_output.cmo \
top.cmo
-if HAVE_PKG_XML_LIGHT
-BOBJS += opt_xml.cmo
-OCAMLPACKAGES += -package xml-light
-endif
if HAVE_PKG_CALENDAR
BOBJS += opt_calendar.cmo
OCAMLPACKAGES += -package calendar
XOBJS = $(BOBJS:.cmo=.cmx)
-OCAMLFLAGS = -g -warn-error +C+D+E+F+L+M+P+S+U+V+Y+Z+X-3 -ccopt '@CFLAGS@'
-OCAMLLIBS =
+OCAMLFLAGS = \
+ -g \
+ -warn-error +C+D+E+F+L+M+P+S+U+V+Y+Z+X-3 \
+ -ccopt '$(CFLAGS)'
+OCAMLLIBS = $(LIBXML2_LIBS)
bin_PROGRAMS = virt-top
-virt_top_SOURCES = dummy.c
+virt_top_SOURCES = xml-c.c
+virt_top_CFLAGS = \
+ $(LIBXML2_CFLAGS) \
+ -I$(libdir)/ocaml
if !HAVE_OCAMLOPT
OBJECTS = $(BOBJS)
to deal with keypresses, help screens and so on.
opt_gettext.ml
+
A generated file which adds gettext support if ocaml-gettext
was found at configure time, or else stubs it out.
- opt_xml.ml
-
- Any code which needs the optional xml-light library goes
- in here. Mainly for parsing domain XML descriptions to get
- the list of block devices and network interfaces.
-
- The reason for having it in a separate file is so that we
- don't depend on xml-light.
-
opt_calendar.ml
Any code which needs the optional ocaml-calendar library
main.ml
This is just a small bit of code to glue the modules together
- Top + Opt_xml? + Opt_calendar?
+ Top + Opt_calendar?
The man-page is generated from the single file:
(* 'top'-like tool for libvirt domains.
- (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc.
+ (C) Copyright 2007-2021 Richard W.M. Jones, Red Hat Inc.
http://libvirt.org/
This program is free software; you can redistribute it and/or modify
open Utils
open Types
-(* Hook for XML support (see [opt_xml.ml]). *)
-let parse_device_xml : (int -> [>`R] D.t -> string list * string list) ref =
- ref (
- fun _ _ -> [], []
- )
-
(* Intermediate "domain + stats" structure that we use to collect
* everything we know about a domain within the collect function.
*)
let get_devices id dom =
try Hashtbl.find devices id
with Not_found ->
- let blkdevs, netifs = (!parse_device_xml) id dom in
+ let blkdevs, netifs = Xml.parse_device_xml dom in
Hashtbl.replace devices id (blkdevs, netifs);
blkdevs, netifs
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)
-(* Hook for [Opt_xml] to override (if present). *)
-val parse_device_xml :
- (int -> [ `R ] Libvirt.Domain.t -> string list * string list) ref
-
(* Intermediate "domain + stats" structure that we use to collect
* everything we know about a domain within the collect function.
*)
+++ /dev/null
-/* Dummy source, to be used for OCaml-based tools with no C sources. */
-enum { foo = 1 };
+++ /dev/null
-(* 'top'-like tool for libvirt domains.
- (C) Copyright 2007-2009 Richard W.M. Jones, Red Hat Inc.
- http://libvirt.org/
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- This file contains all code which requires xml-light.
-*)
-
-open Opt_gettext.Gettext
-
-module C = Libvirt.Connect
-module D = Libvirt.Domain
-module N = Libvirt.Network ;;
-
-Collect.parse_device_xml :=
-fun id dom ->
- try
- let xml = D.get_xml_desc dom in
- let xml = Xml.parse_string xml in
- let devices =
- match xml with
- | Xml.Element ("domain", _, children) ->
- let devices =
- List.filter_map (
- function
- | Xml.Element ("devices", _, devices) -> Some devices
- | _ -> None
- ) children in
- List.concat devices
- | _ ->
- failwith (s_ "get_xml_desc didn't return <domain/>") 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 blkdevs =
- List.filter_map (
- function
- | Xml.Element ("disk", _, children) -> target_dev_of children
- | _ -> None
- ) devices in
- let netifs =
- List.filter_map (
- function
- | Xml.Element ("interface", _, children) -> target_dev_of children
- | _ -> None
- ) devices in
- blkdevs, netifs
- with
- | Xml.Error _
- | Libvirt.Virterror _ -> [], [] (* ignore transient errs *)
--- /dev/null
+/* 'top'-like tool for libvirt domains.
+ (C) Copyright 2007-2021 Richard W.M. Jones, Red Hat Inc.
+ http://libvirt.org/
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+*/
+
+#include <config.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+
+#include <libxml/xpath.h>
+#include <libxml/xpathInternals.h>
+
+/* xpathobj contains a list of dev attributes, return the list
+ * as an OCaml array of strings.
+ */
+static value
+get_devs (xmlDocPtr doc, xmlXPathObjectPtr xpathobj)
+{
+ CAMLparam0 ();
+ CAMLlocal2 (rv, nodev);
+ const xmlNodeSetPtr nodes = xpathobj->nodesetval;
+ size_t i, nr_nodes;
+ xmlNodePtr node;
+ char *str;
+ xmlAttrPtr attr;
+
+ if (nodes == NULL || nodes->nodeNr == 0)
+ rv = caml_alloc (0, 0);
+ else {
+ /* Count the nodes that contain data. */
+ nr_nodes = 0;
+ for (i = 0; i < nodes->nodeNr; ++i) {
+ node = nodes->nodeTab[i];
+ if (node->type != XML_ATTRIBUTE_NODE)
+ continue;
+ nr_nodes++;
+ }
+
+ rv = caml_alloc (nr_nodes, 0);
+ nr_nodes = 0;
+ for (i = 0; i < nodes->nodeNr; ++i) {
+ node = nodes->nodeTab[i];
+ if (node->type != XML_ATTRIBUTE_NODE)
+ continue;
+ attr = (xmlAttrPtr) node;
+ str = (char *) xmlNodeListGetString (doc, attr->children, 1);
+ nodev = caml_copy_string (str);
+ free (str);
+ Store_field (rv, nr_nodes, nodev);
+ nr_nodes++;
+ }
+ }
+
+ CAMLreturn (rv);
+}
+
+/* external get_blk_net_devs : string -> string array * string array */
+value
+get_blk_net_devs (value xmlv)
+{
+ CAMLparam1 (xmlv);
+ CAMLlocal3 (rv, blkdevs, netifs);
+ xmlDocPtr doc;
+ xmlXPathContextPtr xpathctx;
+ xmlXPathObjectPtr xpathobj;
+ const char *expr;
+
+ /* For security reasons, call xmlReadMemory (not xmlParseMemory) and
+ * pass XML_PARSE_NONET.
+ */
+ doc = xmlReadMemory (String_val (xmlv), caml_string_length (xmlv),
+ NULL, NULL, XML_PARSE_NONET);
+ if (doc == NULL)
+ caml_invalid_argument ("xmlReadMemory: unable to parse XML");
+
+ xpathctx = xmlXPathNewContext (doc);
+ if (xpathctx == NULL)
+ caml_invalid_argument ("xmlXPathNewContext: unable to create new context");
+
+ expr = "//devices/disk/target/@dev";
+ xpathobj = xmlXPathEvalExpression (BAD_CAST expr, xpathctx);
+ if (xpathobj == NULL)
+ caml_invalid_argument (expr);
+
+ blkdevs = get_devs (doc, xpathobj);
+ xmlXPathFreeObject (xpathobj);
+
+ expr = "//devices/interface/target/@dev";
+ xpathobj = xmlXPathEvalExpression (BAD_CAST expr, xpathctx);
+ if (xpathobj == NULL)
+ caml_invalid_argument (expr);
+
+ netifs = get_devs (doc, xpathobj);
+ xmlXPathFreeObject (xpathobj);
+
+ xmlXPathFreeContext (xpathctx);
+ xmlFreeDoc (doc);
+
+ rv = caml_alloc (2, 0);
+ Store_field (rv, 0, blkdevs);
+ Store_field (rv, 1, netifs);
+ CAMLreturn (rv);
+}
--- /dev/null
+(* 'top'-like tool for libvirt domains.
+ (C) Copyright 2007-2021 Richard W.M. Jones, Red Hat Inc.
+ http://libvirt.org/
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+*)
+
+module D = Libvirt.Domain
+
+external get_blk_net_devs : string -> string array * string array
+ = "get_blk_net_devs"
+
+let parse_device_xml dom =
+ try
+ let xml = D.get_xml_desc dom in
+ let blkdevs, netifs = get_blk_net_devs xml in
+ Array.to_list blkdevs, Array.to_list netifs
+ with
+ | Invalid_argument _
+ | Libvirt.Virterror _ -> [], [] (* ignore transient errors *)
git.annexia.org / virt-top.git / commitdiff