From 5937a2ef820c7a0ddc4039202c0509a6fd52583d Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 3 Nov 2021 19:24:22 +0000 Subject: [PATCH] Remove dependency on xml-light, replace with libxml2 This commit removes the dependency on the ancient and dead upstream xml-light light. It is replaced with the C library libxml2. This introduces a small amount of C code to interface with libxml2 and parse the libvirt domain XML into the list of block devices and network devices (using XPath). --- README | 2 +- configure.ac | 5 ++- po/POTFILES | 2 +- po/POTFILES-ml | 2 +- src/.depend | 10 ++--- src/Makefile.am | 23 ++++++----- src/README | 12 +----- src/collect.ml | 10 +---- src/collect.mli | 4 -- src/dummy.c | 2 - src/opt_xml.ml | 67 ------------------------------ src/xml-c.c | 124 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/xml.ml | 32 +++++++++++++++ 13 files changed, 183 insertions(+), 112 deletions(-) delete mode 100644 src/dummy.c delete mode 100644 src/opt_xml.ml create mode 100644 src/xml-c.c create mode 100644 src/xml.ml diff --git a/README b/README index 70d0683..da72740 100644 --- a/README +++ b/README @@ -20,10 +20,10 @@ Requirements 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 diff --git a/configure.ac b/configure.ac index 316be00..d31d042 100644 --- a/configure.ac +++ b/configure.ac @@ -36,6 +36,9 @@ AM_PROG_CC_C_O 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 @@ -70,11 +73,9 @@ fi 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 diff --git a/po/POTFILES b/po/POTFILES index 22b1625..22c6267 100644 --- a/po/POTFILES +++ b/po/POTFILES @@ -1 +1 @@ -./src/dummy.c +./src/xml-c.c diff --git a/po/POTFILES-ml b/po/POTFILES-ml index b6356eb..249c66b 100644 --- a/po/POTFILES-ml +++ b/po/POTFILES-ml @@ -4,7 +4,6 @@ ./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 @@ -12,3 +11,4 @@ ./src/types.ml ./src/utils.ml ./src/version.ml +./src/xml.ml diff --git a/src/.depend b/src/.depend index ffca8e3..aad72ab 100644 --- a/src/.depend +++ b/src/.depend @@ -1,10 +1,12 @@ # 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 @@ -35,12 +37,6 @@ opt_calendar.cmx : \ 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 \ @@ -116,3 +112,5 @@ utils.cmx : \ utils.cmi : version.cmo : version.cmx : +xml.cmo : +xml.cmx : diff --git a/src/Makefile.am b/src/Makefile.am index 03e4b1c..baf8ce4 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -24,11 +24,9 @@ EXTRA_DIST = \ 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 \ @@ -42,7 +40,9 @@ EXTRA_DIST = \ utils.ml \ utils.mli \ version.ml \ - virt-top.pod + virt-top.pod \ + xml-c.c \ + xml.ml OCAMLPACKAGES = -package unix,curses,str,libvirt @@ -55,16 +55,13 @@ BOBJS = \ 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 @@ -73,12 +70,18 @@ BOBJS += main.cmo 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) diff --git a/src/README b/src/README index 61d2c77..e49fd48 100644 --- a/src/README +++ b/src/README @@ -41,18 +41,10 @@ The code is structured into these files: 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 @@ -62,7 +54,7 @@ The code is structured into these files: 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: diff --git a/src/collect.ml b/src/collect.ml index 0c673e1..c8a390c 100644 --- a/src/collect.ml +++ b/src/collect.ml @@ -1,5 +1,5 @@ (* '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 @@ -25,12 +25,6 @@ open Printf 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. *) @@ -94,7 +88,7 @@ let devices = Hashtbl.create 13 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 diff --git a/src/collect.mli b/src/collect.mli index 3c5492f..72f0800 100644 --- a/src/collect.mli +++ b/src/collect.mli @@ -17,10 +17,6 @@ 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. *) diff --git a/src/dummy.c b/src/dummy.c deleted file mode 100644 index ebab619..0000000 --- a/src/dummy.c +++ /dev/null @@ -1,2 +0,0 @@ -/* Dummy source, to be used for OCaml-based tools with no C sources. */ -enum { foo = 1 }; diff --git a/src/opt_xml.ml b/src/opt_xml.ml deleted file mode 100644 index 25ef0ad..0000000 --- a/src/opt_xml.ml +++ /dev/null @@ -1,67 +0,0 @@ -(* '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 ") 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 *) diff --git a/src/xml-c.c b/src/xml-c.c new file mode 100644 index 0000000..72042bf --- /dev/null +++ b/src/xml-c.c @@ -0,0 +1,124 @@ +/* '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 + +#include +#include +#include + +#include +#include +#include +#include + +#include +#include + +/* 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); +} diff --git a/src/xml.ml b/src/xml.ml new file mode 100644 index 0000000..d11ce45 --- /dev/null +++ b/src/xml.ml @@ -0,0 +1,32 @@ +(* '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 *) -- 1.8.3.1