1 (* 'top'-like tool for libvirt domains.
2 (C) Copyright 2007-2009 Richard W.M. Jones, Red Hat Inc.
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
19 This file contains all code which requires xml-light.
24 open Opt_gettext.Gettext
26 module C = Libvirt.Connect
27 module D = Libvirt.Domain
28 module N = Libvirt.Network ;;
30 Collect.parse_device_xml :=
33 let xml = D.get_xml_desc dom in
34 let xml = Xml.parse_string xml in
37 | Xml.Element ("domain", _, children) ->
41 | Xml.Element ("devices", _, devices) -> Some devices
46 failwith (s_ "get_xml_desc didn't return <domain/>") in
47 let rec target_dev_of = function
49 | Xml.Element ("target", attrs, _) :: rest ->
50 (try Some (List.assoc "dev" attrs)
51 with Not_found -> target_dev_of rest)
52 | _ :: rest -> target_dev_of rest
57 | Xml.Element ("disk", _, children) -> target_dev_of children
63 | Xml.Element ("interface", _, children) -> target_dev_of children
69 | Libvirt.Virterror _ -> [], [] (* ignore transient errs *)