1 (* 'top'-like tool for libvirt domains.
2 (C) Copyright 2007 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 module C = Libvirt.Connect
25 module D = Libvirt.Domain
26 module N = Libvirt.Network ;;
28 Virt_top.parse_device_xml :=
31 let xml = D.get_xml_desc dom in
32 let xml = Xml.parse_string xml in
35 | Xml.Element ("domain", _, children) ->
39 | Xml.Element ("devices", _, devices) -> Some devices
44 failwith "get_xml_desc didn't return <domain/>" in
45 let rec target_dev_of = function
47 | Xml.Element ("target", attrs, _) :: rest ->
48 (try Some (List.assoc "dev" attrs)
49 with Not_found -> target_dev_of rest)
50 | _ :: rest -> target_dev_of rest
55 | Xml.Element ("disk", _, children) -> target_dev_of children
61 | Xml.Element ("interface", _, children) -> target_dev_of children
67 | Libvirt.Virterror _ -> [], [] (* ignore transient errs *)