src/opt_xml.ml

   1 (* 'top'-like tool for libvirt domains.
   2    (C) Copyright 2007-2009 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   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.
   9
  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.
  14
  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.
  18
  19    This file contains all code which requires xml-light.
  20 *)
  21
  22 open ExtList
  23
  24 open Opt_gettext.Gettext
  25
  26 module C = Libvirt.Connect
  27 module D = Libvirt.Domain
  28 module N = Libvirt.Network ;;
  29
  30 Collect.parse_device_xml :=
  31 fun id dom ->
  32   try
  33     let xml = D.get_xml_desc dom in
  34     let xml = Xml.parse_string xml in
  35     let devices =
  36       match xml with
  37       | Xml.Element ("domain", _, children) ->
  38           let devices =
  39             List.filter_map (
  40               function
  41               | Xml.Element ("devices", _, devices) -> Some devices
  42               | _ -> None
  43             ) children in
  44           List.concat devices
  45       | _ ->
  46           failwith (s_ "get_xml_desc didn't return <domain/>") in
  47     let rec target_dev_of = function
  48       | [] -> None
  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
  53     in
  54     let blkdevs =
  55       List.filter_map (
  56         function
  57         | Xml.Element ("disk", _, children) -> target_dev_of children
  58         | _ -> None
  59       ) devices in
  60     let netifs =
  61       List.filter_map (
  62         function
  63         | Xml.Element ("interface", _, children) -> target_dev_of children
  64         | _ -> None
  65       ) devices in
  66     blkdevs, netifs
  67   with
  68   | Xml.Error _
  69   | Libvirt.Virterror _ -> [], [] (* ignore transient errs *)