Implement version 3 of virConnectListAllDomains.

diff --git a/examples/list_domains.ml b/examples/list_domains.ml
index 2e9e436..6b04932 100644 (file)
--- a/examples/list_domains.ml
+++ b/examples/list_domains.ml
@@ -10,6 +10,15 @@ module C = Libvirt.Connect
 module D = Libvirt.Domain
 module N = Libvirt.Network
 
+let string_of_state = function
+  | D.InfoNoState -> "no state"
+  | D.InfoRunning -> "running"
+  | D.InfoBlocked -> "blocked"
+  | D.InfoPaused -> "paused"
+  | D.InfoShutdown -> "shutdown"
+  | D.InfoShutoff -> "shutoff"
+  | D.InfoCrashed -> "crashed"
+
 let () =
   try
     let name =
@@ -19,21 +28,16 @@ let () =
        None in
     let conn = C.connect_readonly ?name () in
 
-    (* List running domains. *)
-    let domains =
-      fst (Libvirt.get_domains conn ~want_info:false [D.ListActive]) in
-    List.iter (
-      fun dom ->
-       printf "%8d %s\n%!" (D.get_id dom) (D.get_name dom)
-    ) domains;
-
-    (* List inactive domains. *)
-    let domains =
-      fst (Libvirt.get_domains conn ~want_info:false [D.ListInactive]) in
+    (* List all domains (running and inactive). *)
+    let domains = D.get_domains_and_infos conn [D.ListAll] in
     List.iter (
-      fun dom ->
-       printf "inactive %s\n%!" (D.get_name dom)
-    ) domains;
+      fun (dom, info) ->
+       if info.D.state <> D.InfoShutoff then
+         printf "%8d %-20s %s\n%!"
+           (D.get_id dom) (D.get_name dom) (string_of_state info.D.state)
+       else
+         printf "%8s %-20s shutoff\n%!" "" (D.get_name dom)
+    ) domains
   with
     Libvirt.Virterror err ->
       eprintf "error: %s\n" (Libvirt.Virterror.to_string err)

diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 1e37136..ec8c9e8 100644 (file)
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -105,6 +105,213 @@ struct
   external const : [>`R] t -> ro t = "%identity"
 end
 
+module Virterror =
+struct
+  type code =
+    | VIR_ERR_OK
+    | VIR_ERR_INTERNAL_ERROR
+    | VIR_ERR_NO_MEMORY
+    | VIR_ERR_NO_SUPPORT
+    | VIR_ERR_UNKNOWN_HOST
+    | VIR_ERR_NO_CONNECT
+    | VIR_ERR_INVALID_CONN
+    | VIR_ERR_INVALID_DOMAIN
+    | VIR_ERR_INVALID_ARG
+    | VIR_ERR_OPERATION_FAILED
+    | VIR_ERR_GET_FAILED
+    | VIR_ERR_POST_FAILED
+    | VIR_ERR_HTTP_ERROR
+    | VIR_ERR_SEXPR_SERIAL
+    | VIR_ERR_NO_XEN
+    | VIR_ERR_XEN_CALL
+    | VIR_ERR_OS_TYPE
+    | VIR_ERR_NO_KERNEL
+    | VIR_ERR_NO_ROOT
+    | VIR_ERR_NO_SOURCE
+    | VIR_ERR_NO_TARGET
+    | VIR_ERR_NO_NAME
+    | VIR_ERR_NO_OS
+    | VIR_ERR_NO_DEVICE
+    | VIR_ERR_NO_XENSTORE
+    | VIR_ERR_DRIVER_FULL
+    | VIR_ERR_CALL_FAILED
+    | VIR_ERR_XML_ERROR
+    | VIR_ERR_DOM_EXIST
+    | VIR_ERR_OPERATION_DENIED
+    | VIR_ERR_OPEN_FAILED
+    | VIR_ERR_READ_FAILED
+    | VIR_ERR_PARSE_FAILED
+    | VIR_ERR_CONF_SYNTAX
+    | VIR_ERR_WRITE_FAILED
+    | VIR_ERR_XML_DETAIL
+    | VIR_ERR_INVALID_NETWORK
+    | VIR_ERR_NETWORK_EXIST
+    | VIR_ERR_SYSTEM_ERROR
+    | VIR_ERR_RPC
+    | VIR_ERR_GNUTLS_ERROR
+    | VIR_WAR_NO_NETWORK
+    | VIR_ERR_NO_DOMAIN
+    | VIR_ERR_NO_NETWORK
+    | VIR_ERR_INVALID_MAC
+    | VIR_ERR_AUTH_FAILED
+    | VIR_ERR_INVALID_STORAGE_POOL
+    | VIR_ERR_INVALID_STORAGE_VOL
+    | VIR_WAR_NO_STORAGE
+    | VIR_ERR_NO_STORAGE_POOL
+    | VIR_ERR_NO_STORAGE_VOL
+    | VIR_ERR_UNKNOWN of int
+
+  let string_of_code = function
+    | VIR_ERR_OK -> "VIR_ERR_OK"
+    | VIR_ERR_INTERNAL_ERROR -> "VIR_ERR_INTERNAL_ERROR"
+    | VIR_ERR_NO_MEMORY -> "VIR_ERR_NO_MEMORY"
+    | VIR_ERR_NO_SUPPORT -> "VIR_ERR_NO_SUPPORT"
+    | VIR_ERR_UNKNOWN_HOST -> "VIR_ERR_UNKNOWN_HOST"
+    | VIR_ERR_NO_CONNECT -> "VIR_ERR_NO_CONNECT"
+    | VIR_ERR_INVALID_CONN -> "VIR_ERR_INVALID_CONN"
+    | VIR_ERR_INVALID_DOMAIN -> "VIR_ERR_INVALID_DOMAIN"
+    | VIR_ERR_INVALID_ARG -> "VIR_ERR_INVALID_ARG"
+    | VIR_ERR_OPERATION_FAILED -> "VIR_ERR_OPERATION_FAILED"
+    | VIR_ERR_GET_FAILED -> "VIR_ERR_GET_FAILED"
+    | VIR_ERR_POST_FAILED -> "VIR_ERR_POST_FAILED"
+    | VIR_ERR_HTTP_ERROR -> "VIR_ERR_HTTP_ERROR"
+    | VIR_ERR_SEXPR_SERIAL -> "VIR_ERR_SEXPR_SERIAL"
+    | VIR_ERR_NO_XEN -> "VIR_ERR_NO_XEN"
+    | VIR_ERR_XEN_CALL -> "VIR_ERR_XEN_CALL"
+    | VIR_ERR_OS_TYPE -> "VIR_ERR_OS_TYPE"
+    | VIR_ERR_NO_KERNEL -> "VIR_ERR_NO_KERNEL"
+    | VIR_ERR_NO_ROOT -> "VIR_ERR_NO_ROOT"
+    | VIR_ERR_NO_SOURCE -> "VIR_ERR_NO_SOURCE"
+    | VIR_ERR_NO_TARGET -> "VIR_ERR_NO_TARGET"
+    | VIR_ERR_NO_NAME -> "VIR_ERR_NO_NAME"
+    | VIR_ERR_NO_OS -> "VIR_ERR_NO_OS"
+    | VIR_ERR_NO_DEVICE -> "VIR_ERR_NO_DEVICE"
+    | VIR_ERR_NO_XENSTORE -> "VIR_ERR_NO_XENSTORE"
+    | VIR_ERR_DRIVER_FULL -> "VIR_ERR_DRIVER_FULL"
+    | VIR_ERR_CALL_FAILED -> "VIR_ERR_CALL_FAILED"
+    | VIR_ERR_XML_ERROR -> "VIR_ERR_XML_ERROR"
+    | VIR_ERR_DOM_EXIST -> "VIR_ERR_DOM_EXIST"
+    | VIR_ERR_OPERATION_DENIED -> "VIR_ERR_OPERATION_DENIED"
+    | VIR_ERR_OPEN_FAILED -> "VIR_ERR_OPEN_FAILED"
+    | VIR_ERR_READ_FAILED -> "VIR_ERR_READ_FAILED"
+    | VIR_ERR_PARSE_FAILED -> "VIR_ERR_PARSE_FAILED"
+    | VIR_ERR_CONF_SYNTAX -> "VIR_ERR_CONF_SYNTAX"
+    | VIR_ERR_WRITE_FAILED -> "VIR_ERR_WRITE_FAILED"
+    | VIR_ERR_XML_DETAIL -> "VIR_ERR_XML_DETAIL"
+    | VIR_ERR_INVALID_NETWORK -> "VIR_ERR_INVALID_NETWORK"
+    | VIR_ERR_NETWORK_EXIST -> "VIR_ERR_NETWORK_EXIST"
+    | VIR_ERR_SYSTEM_ERROR -> "VIR_ERR_SYSTEM_ERROR"
+    | VIR_ERR_RPC -> "VIR_ERR_RPC"
+    | VIR_ERR_GNUTLS_ERROR -> "VIR_ERR_GNUTLS_ERROR"
+    | VIR_WAR_NO_NETWORK -> "VIR_WAR_NO_NETWORK"
+    | VIR_ERR_NO_DOMAIN -> "VIR_ERR_NO_DOMAIN"
+    | VIR_ERR_NO_NETWORK -> "VIR_ERR_NO_NETWORK"
+    | VIR_ERR_INVALID_MAC -> "VIR_ERR_INVALID_MAC"
+    | VIR_ERR_AUTH_FAILED -> "VIR_ERR_AUTH_FAILED"
+    | VIR_ERR_INVALID_STORAGE_POOL -> "VIR_ERR_INVALID_STORAGE_POOL"
+    | VIR_ERR_INVALID_STORAGE_VOL -> "VIR_ERR_INVALID_STORAGE_VOL"
+    | VIR_WAR_NO_STORAGE -> "VIR_WAR_NO_STORAGE"
+    | VIR_ERR_NO_STORAGE_POOL -> "VIR_ERR_NO_STORAGE_POOL"
+    | VIR_ERR_NO_STORAGE_VOL -> "VIR_ERR_NO_STORAGE_VOL"
+    | VIR_ERR_UNKNOWN i -> "VIR_ERR_" ^ string_of_int i
+
+  type domain =
+    | VIR_FROM_NONE
+    | VIR_FROM_XEN
+    | VIR_FROM_XEND
+    | VIR_FROM_XENSTORE
+    | VIR_FROM_SEXPR
+    | VIR_FROM_XML
+    | VIR_FROM_DOM
+    | VIR_FROM_RPC
+    | VIR_FROM_PROXY
+    | VIR_FROM_CONF
+    | VIR_FROM_QEMU
+    | VIR_FROM_NET
+    | VIR_FROM_TEST
+    | VIR_FROM_REMOTE
+    | VIR_FROM_OPENVZ
+    | VIR_FROM_XENXM
+    | VIR_FROM_STATS_LINUX
+    | VIR_FROM_STORAGE
+    | VIR_FROM_UNKNOWN of int
+
+  let string_of_domain = function
+    | VIR_FROM_NONE -> "VIR_FROM_NONE"
+    | VIR_FROM_XEN -> "VIR_FROM_XEN"
+    | VIR_FROM_XEND -> "VIR_FROM_XEND"
+    | VIR_FROM_XENSTORE -> "VIR_FROM_XENSTORE"
+    | VIR_FROM_SEXPR -> "VIR_FROM_SEXPR"
+    | VIR_FROM_XML -> "VIR_FROM_XML"
+    | VIR_FROM_DOM -> "VIR_FROM_DOM"
+    | VIR_FROM_RPC -> "VIR_FROM_RPC"
+    | VIR_FROM_PROXY -> "VIR_FROM_PROXY"
+    | VIR_FROM_CONF -> "VIR_FROM_CONF"
+    | VIR_FROM_QEMU -> "VIR_FROM_QEMU"
+    | VIR_FROM_NET -> "VIR_FROM_NET"
+    | VIR_FROM_TEST -> "VIR_FROM_TEST"
+    | VIR_FROM_REMOTE -> "VIR_FROM_REMOTE"
+    | VIR_FROM_OPENVZ -> "VIR_FROM_OPENVZ"
+    | VIR_FROM_XENXM -> "VIR_FROM_XENXM"
+    | VIR_FROM_STATS_LINUX -> "VIR_FROM_STATS_LINUX"
+    | VIR_FROM_STORAGE -> "VIR_FROM_STORAGE"
+    | VIR_FROM_UNKNOWN i -> "VIR_FROM_" ^ string_of_int i
+
+  type level =
+    | VIR_ERR_NONE
+    | VIR_ERR_WARNING
+    | VIR_ERR_ERROR
+    | VIR_ERR_UNKNOWN_LEVEL of int
+
+  let string_of_level = function
+    | VIR_ERR_NONE -> "VIR_ERR_NONE"
+    | VIR_ERR_WARNING -> "VIR_ERR_WARNING"
+    | VIR_ERR_ERROR -> "VIR_ERR_ERROR"
+    | VIR_ERR_UNKNOWN_LEVEL i -> "VIR_ERR_LEVEL_" ^ string_of_int i
+
+  type t = {
+    code : code;
+    domain : domain;
+    message : string option;
+    level : level;
+    str1 : string option;
+    str2 : string option;
+    str3 : string option;
+    int1 : int32;
+    int2 : int32;
+  }
+
+  let to_string { code = code; domain = domain; message = message } =
+    let buf = Buffer.create 128 in
+    Buffer.add_string buf "libvirt: ";
+    Buffer.add_string buf (string_of_code code);
+    Buffer.add_string buf ": ";
+    Buffer.add_string buf (string_of_domain domain);
+    Buffer.add_string buf ": ";
+    (match message with Some msg -> Buffer.add_string buf msg | None -> ());
+    Buffer.contents buf
+
+  external get_last_error : unit -> t option = "ocaml_libvirt_virterror_get_last_error"
+  external get_last_conn_error : [>`R] Connect.t -> t option = "ocaml_libvirt_virterror_get_last_conn_error"
+  external reset_last_error : unit -> unit = "ocaml_libvirt_virterror_reset_last_error"
+  external reset_last_conn_error : [>`R] Connect.t -> unit = "ocaml_libvirt_virterror_reset_last_conn_error"
+
+  let no_error () =
+    { code = VIR_ERR_OK; domain = VIR_FROM_NONE;
+      message = None; level = VIR_ERR_NONE;
+      str1 = None; str2 = None; str3 = None;
+      int1 = 0_l; int2 = 0_l }
+end
+
+exception Virterror of Virterror.t
+exception Not_supported of string
+
+let rec map_ignore_errors f = function
+  | [] -> []
+  | x :: xs ->
+      try f x :: map_ignore_errors f xs
+      with Virterror _ -> map_ignore_errors f xs
+
 module Domain =
 struct
   type 'rw t
@@ -141,8 +348,6 @@ struct
   type memory_flag = Virtual
 
   type list_flag =
-    | ListNoState | ListRunning | ListBlocked
-    | ListPaused | ListShutdown | ListShutoff | ListCrashed
     | ListActive
     | ListInactive
     | ListAll
@@ -224,6 +429,95 @@ struct
   external memory_peek : [>`R] t -> memory_flag list -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_memory_peek_bytecode" "ocaml_libvirt_domain_memory_peek_native"
 
   external const : [>`R] t -> ro t = "%identity"
+
+  (* First time we are called, we will check if
+   * virConnectListAllDomains is supported.
+   *)
+  let have_list_all_domains = ref None
+
+  let check_have_list_all_domains conn =
+    match !have_list_all_domains with
+    | Some v -> v
+    | None ->
+       (* Check if virConnectListAllDomains is supported
+        * by this version of libvirt.
+        *)
+       let v =
+         (* libvirt has a short-cut which makes this very quick ... *)
+         try ignore (list_all_domains conn []); true
+         with Not_supported "virConnectListAllDomains" -> false in
+       have_list_all_domains := Some v;
+       v
+
+  let get_domains conn flags =
+    let have_list_all_domains = check_have_list_all_domains conn in
+
+    if have_list_all_domains then (
+      (* Good, we can use the shiny new method. *)
+      let doms, _ = list_all_domains conn ~want_info:false flags in
+      Array.to_list doms
+    )
+    else (
+      (* Old/slow/inefficient method. *)
+      let get_active, get_inactive =
+       if List.mem ListAll flags then
+         (true, true)
+       else
+         (List.mem ListActive flags, List.mem ListInactive flags) in
+      let active_doms =
+       if get_active then (
+         let n = Connect.num_of_domains conn in
+         let ids = Connect.list_domains conn n in
+         let ids = Array.to_list ids in
+         map_ignore_errors (lookup_by_id conn) ids
+       ) else [] in
+
+      let inactive_doms =
+       if get_inactive then (
+         let n = Connect.num_of_defined_domains conn in
+         let names = Connect.list_defined_domains conn n in
+         let names = Array.to_list names in
+         map_ignore_errors (lookup_by_name conn) names
+       ) else [] in
+
+      active_doms @ inactive_doms
+    )
+
+  let get_domains_and_infos conn flags =
+    let have_list_all_domains = check_have_list_all_domains conn in
+
+    if have_list_all_domains then (
+      (* Good, we can use the shiny new method. *)
+      let doms, infos = list_all_domains conn ~want_info:true flags in
+      let doms = Array.to_list doms and infos = Array.to_list infos in
+      List.combine doms infos
+    )
+    else (
+      (* Old/slow/inefficient method. *)
+      let get_active, get_inactive =
+       if List.mem ListAll flags then
+         (true, true)
+       else (List.mem ListActive flags, List.mem ListInactive flags) in
+      let active_doms =
+       if get_active then (
+         let n = Connect.num_of_domains conn in
+         let ids = Connect.list_domains conn n in
+         let ids = Array.to_list ids in
+         map_ignore_errors (lookup_by_id conn) ids
+       ) else [] in
+
+      let inactive_doms =
+       if get_inactive then (
+         let n = Connect.num_of_defined_domains conn in
+         let names = Connect.list_defined_domains conn n in
+         let names = Array.to_list names in
+         map_ignore_errors (lookup_by_name conn) names
+       ) else [] in
+
+      let doms = active_doms @ inactive_doms in
+
+      map_ignore_errors (fun dom -> (dom, get_info dom)) doms
+    )
 end
 
 module Network =
@@ -335,306 +629,6 @@ struct
   external const : ('a, [>`R]) t -> ('a, ro) t = "%identity"
 end
 
-module Virterror =
-struct
-  type code =
-    | VIR_ERR_OK
-    | VIR_ERR_INTERNAL_ERROR
-    | VIR_ERR_NO_MEMORY
-    | VIR_ERR_NO_SUPPORT
-    | VIR_ERR_UNKNOWN_HOST
-    | VIR_ERR_NO_CONNECT
-    | VIR_ERR_INVALID_CONN
-    | VIR_ERR_INVALID_DOMAIN
-    | VIR_ERR_INVALID_ARG
-    | VIR_ERR_OPERATION_FAILED
-    | VIR_ERR_GET_FAILED
-    | VIR_ERR_POST_FAILED
-    | VIR_ERR_HTTP_ERROR
-    | VIR_ERR_SEXPR_SERIAL
-    | VIR_ERR_NO_XEN
-    | VIR_ERR_XEN_CALL
-    | VIR_ERR_OS_TYPE
-    | VIR_ERR_NO_KERNEL
-    | VIR_ERR_NO_ROOT
-    | VIR_ERR_NO_SOURCE
-    | VIR_ERR_NO_TARGET
-    | VIR_ERR_NO_NAME
-    | VIR_ERR_NO_OS
-    | VIR_ERR_NO_DEVICE
-    | VIR_ERR_NO_XENSTORE
-    | VIR_ERR_DRIVER_FULL
-    | VIR_ERR_CALL_FAILED
-    | VIR_ERR_XML_ERROR
-    | VIR_ERR_DOM_EXIST
-    | VIR_ERR_OPERATION_DENIED
-    | VIR_ERR_OPEN_FAILED
-    | VIR_ERR_READ_FAILED
-    | VIR_ERR_PARSE_FAILED
-    | VIR_ERR_CONF_SYNTAX
-    | VIR_ERR_WRITE_FAILED
-    | VIR_ERR_XML_DETAIL
-    | VIR_ERR_INVALID_NETWORK
-    | VIR_ERR_NETWORK_EXIST
-    | VIR_ERR_SYSTEM_ERROR
-    | VIR_ERR_RPC
-    | VIR_ERR_GNUTLS_ERROR
-    | VIR_WAR_NO_NETWORK
-    | VIR_ERR_NO_DOMAIN
-    | VIR_ERR_NO_NETWORK
-    | VIR_ERR_INVALID_MAC
-    | VIR_ERR_AUTH_FAILED
-    | VIR_ERR_INVALID_STORAGE_POOL
-    | VIR_ERR_INVALID_STORAGE_VOL
-    | VIR_WAR_NO_STORAGE
-    | VIR_ERR_NO_STORAGE_POOL
-    | VIR_ERR_NO_STORAGE_VOL
-    | VIR_ERR_UNKNOWN of int
-
-  let string_of_code = function
-    | VIR_ERR_OK -> "VIR_ERR_OK"
-    | VIR_ERR_INTERNAL_ERROR -> "VIR_ERR_INTERNAL_ERROR"
-    | VIR_ERR_NO_MEMORY -> "VIR_ERR_NO_MEMORY"
-    | VIR_ERR_NO_SUPPORT -> "VIR_ERR_NO_SUPPORT"
-    | VIR_ERR_UNKNOWN_HOST -> "VIR_ERR_UNKNOWN_HOST"
-    | VIR_ERR_NO_CONNECT -> "VIR_ERR_NO_CONNECT"
-    | VIR_ERR_INVALID_CONN -> "VIR_ERR_INVALID_CONN"
-    | VIR_ERR_INVALID_DOMAIN -> "VIR_ERR_INVALID_DOMAIN"
-    | VIR_ERR_INVALID_ARG -> "VIR_ERR_INVALID_ARG"
-    | VIR_ERR_OPERATION_FAILED -> "VIR_ERR_OPERATION_FAILED"
-    | VIR_ERR_GET_FAILED -> "VIR_ERR_GET_FAILED"
-    | VIR_ERR_POST_FAILED -> "VIR_ERR_POST_FAILED"
-    | VIR_ERR_HTTP_ERROR -> "VIR_ERR_HTTP_ERROR"
-    | VIR_ERR_SEXPR_SERIAL -> "VIR_ERR_SEXPR_SERIAL"
-    | VIR_ERR_NO_XEN -> "VIR_ERR_NO_XEN"
-    | VIR_ERR_XEN_CALL -> "VIR_ERR_XEN_CALL"
-    | VIR_ERR_OS_TYPE -> "VIR_ERR_OS_TYPE"
-    | VIR_ERR_NO_KERNEL -> "VIR_ERR_NO_KERNEL"
-    | VIR_ERR_NO_ROOT -> "VIR_ERR_NO_ROOT"
-    | VIR_ERR_NO_SOURCE -> "VIR_ERR_NO_SOURCE"
-    | VIR_ERR_NO_TARGET -> "VIR_ERR_NO_TARGET"
-    | VIR_ERR_NO_NAME -> "VIR_ERR_NO_NAME"
-    | VIR_ERR_NO_OS -> "VIR_ERR_NO_OS"
-    | VIR_ERR_NO_DEVICE -> "VIR_ERR_NO_DEVICE"
-    | VIR_ERR_NO_XENSTORE -> "VIR_ERR_NO_XENSTORE"
-    | VIR_ERR_DRIVER_FULL -> "VIR_ERR_DRIVER_FULL"
-    | VIR_ERR_CALL_FAILED -> "VIR_ERR_CALL_FAILED"
-    | VIR_ERR_XML_ERROR -> "VIR_ERR_XML_ERROR"
-    | VIR_ERR_DOM_EXIST -> "VIR_ERR_DOM_EXIST"
-    | VIR_ERR_OPERATION_DENIED -> "VIR_ERR_OPERATION_DENIED"
-    | VIR_ERR_OPEN_FAILED -> "VIR_ERR_OPEN_FAILED"
-    | VIR_ERR_READ_FAILED -> "VIR_ERR_READ_FAILED"
-    | VIR_ERR_PARSE_FAILED -> "VIR_ERR_PARSE_FAILED"
-    | VIR_ERR_CONF_SYNTAX -> "VIR_ERR_CONF_SYNTAX"
-    | VIR_ERR_WRITE_FAILED -> "VIR_ERR_WRITE_FAILED"
-    | VIR_ERR_XML_DETAIL -> "VIR_ERR_XML_DETAIL"
-    | VIR_ERR_INVALID_NETWORK -> "VIR_ERR_INVALID_NETWORK"
-    | VIR_ERR_NETWORK_EXIST -> "VIR_ERR_NETWORK_EXIST"
-    | VIR_ERR_SYSTEM_ERROR -> "VIR_ERR_SYSTEM_ERROR"
-    | VIR_ERR_RPC -> "VIR_ERR_RPC"
-    | VIR_ERR_GNUTLS_ERROR -> "VIR_ERR_GNUTLS_ERROR"
-    | VIR_WAR_NO_NETWORK -> "VIR_WAR_NO_NETWORK"
-    | VIR_ERR_NO_DOMAIN -> "VIR_ERR_NO_DOMAIN"
-    | VIR_ERR_NO_NETWORK -> "VIR_ERR_NO_NETWORK"
-    | VIR_ERR_INVALID_MAC -> "VIR_ERR_INVALID_MAC"
-    | VIR_ERR_AUTH_FAILED -> "VIR_ERR_AUTH_FAILED"
-    | VIR_ERR_INVALID_STORAGE_POOL -> "VIR_ERR_INVALID_STORAGE_POOL"
-    | VIR_ERR_INVALID_STORAGE_VOL -> "VIR_ERR_INVALID_STORAGE_VOL"
-    | VIR_WAR_NO_STORAGE -> "VIR_WAR_NO_STORAGE"
-    | VIR_ERR_NO_STORAGE_POOL -> "VIR_ERR_NO_STORAGE_POOL"
-    | VIR_ERR_NO_STORAGE_VOL -> "VIR_ERR_NO_STORAGE_VOL"
-    | VIR_ERR_UNKNOWN i -> "VIR_ERR_" ^ string_of_int i
-
-  type domain =
-    | VIR_FROM_NONE
-    | VIR_FROM_XEN
-    | VIR_FROM_XEND
-    | VIR_FROM_XENSTORE
-    | VIR_FROM_SEXPR
-    | VIR_FROM_XML
-    | VIR_FROM_DOM
-    | VIR_FROM_RPC
-    | VIR_FROM_PROXY
-    | VIR_FROM_CONF
-    | VIR_FROM_QEMU
-    | VIR_FROM_NET
-    | VIR_FROM_TEST
-    | VIR_FROM_REMOTE
-    | VIR_FROM_OPENVZ
-    | VIR_FROM_XENXM
-    | VIR_FROM_STATS_LINUX
-    | VIR_FROM_STORAGE
-    | VIR_FROM_UNKNOWN of int
-
-  let string_of_domain = function
-    | VIR_FROM_NONE -> "VIR_FROM_NONE"
-    | VIR_FROM_XEN -> "VIR_FROM_XEN"
-    | VIR_FROM_XEND -> "VIR_FROM_XEND"
-    | VIR_FROM_XENSTORE -> "VIR_FROM_XENSTORE"
-    | VIR_FROM_SEXPR -> "VIR_FROM_SEXPR"
-    | VIR_FROM_XML -> "VIR_FROM_XML"
-    | VIR_FROM_DOM -> "VIR_FROM_DOM"
-    | VIR_FROM_RPC -> "VIR_FROM_RPC"
-    | VIR_FROM_PROXY -> "VIR_FROM_PROXY"
-    | VIR_FROM_CONF -> "VIR_FROM_CONF"
-    | VIR_FROM_QEMU -> "VIR_FROM_QEMU"
-    | VIR_FROM_NET -> "VIR_FROM_NET"
-    | VIR_FROM_TEST -> "VIR_FROM_TEST"
-    | VIR_FROM_REMOTE -> "VIR_FROM_REMOTE"
-    | VIR_FROM_OPENVZ -> "VIR_FROM_OPENVZ"
-    | VIR_FROM_XENXM -> "VIR_FROM_XENXM"
-    | VIR_FROM_STATS_LINUX -> "VIR_FROM_STATS_LINUX"
-    | VIR_FROM_STORAGE -> "VIR_FROM_STORAGE"
-    | VIR_FROM_UNKNOWN i -> "VIR_FROM_" ^ string_of_int i
-
-  type level =
-    | VIR_ERR_NONE
-    | VIR_ERR_WARNING
-    | VIR_ERR_ERROR
-    | VIR_ERR_UNKNOWN_LEVEL of int
-
-  let string_of_level = function
-    | VIR_ERR_NONE -> "VIR_ERR_NONE"
-    | VIR_ERR_WARNING -> "VIR_ERR_WARNING"
-    | VIR_ERR_ERROR -> "VIR_ERR_ERROR"
-    | VIR_ERR_UNKNOWN_LEVEL i -> "VIR_ERR_LEVEL_" ^ string_of_int i
-
-  type t = {
-    code : code;
-    domain : domain;
-    message : string option;
-    level : level;
-    str1 : string option;
-    str2 : string option;
-    str3 : string option;
-    int1 : int32;
-    int2 : int32;
-  }
-
-  let to_string { code = code; domain = domain; message = message } =
-    let buf = Buffer.create 128 in
-    Buffer.add_string buf "libvirt: ";
-    Buffer.add_string buf (string_of_code code);
-    Buffer.add_string buf ": ";
-    Buffer.add_string buf (string_of_domain domain);
-    Buffer.add_string buf ": ";
-    (match message with Some msg -> Buffer.add_string buf msg | None -> ());
-    Buffer.contents buf
-
-  external get_last_error : unit -> t option = "ocaml_libvirt_virterror_get_last_error"
-  external get_last_conn_error : [>`R] Connect.t -> t option = "ocaml_libvirt_virterror_get_last_conn_error"
-  external reset_last_error : unit -> unit = "ocaml_libvirt_virterror_reset_last_error"
-  external reset_last_conn_error : [>`R] Connect.t -> unit = "ocaml_libvirt_virterror_reset_last_conn_error"
-
-  let no_error () =
-    { code = VIR_ERR_OK; domain = VIR_FROM_NONE;
-      message = None; level = VIR_ERR_NONE;
-      str1 = None; str2 = None; str3 = None;
-      int1 = 0_l; int2 = 0_l }
-end
-
-exception Virterror of Virterror.t
-exception Not_supported of string
-
-let rec map_ignore_errors f = function
-  | [] -> []
-  | x :: xs ->
-      try f x :: map_ignore_errors f xs
-      with Virterror _ -> map_ignore_errors f xs
-
-(* First time we are called, we will check if
- * virConnectListAllDomains is supported.
- *)
-let have_list_all_domains = ref None
-
-let get_domains conn ?(want_info = true) flags =
-  let have_list_all_domains =
-    match !have_list_all_domains with
-    | Some v -> v
-    | None ->
-       (* Check if virConnectListAllDomains is supported
-        * by this version of libvirt.
-        *)
-       let v =
-         (* libvirt has a short-cut which makes this very quick ... *)
-         try ignore (Domain.list_all_domains conn []); true
-         with Not_supported "virConnectListAllDomains" -> false in
-       have_list_all_domains := Some v;
-       v in
-
-  if have_list_all_domains then (
-    (* Good, we can use the shiny new method. *)
-    let doms, infos = Domain.list_all_domains conn ~want_info flags in
-    Array.to_list doms, Array.to_list infos
-  )
-  else (
-    (* Old/slow/inefficient method. *)
-    let get_all, get_active, get_inactive, another_flag =
-      let rec loop ((all, active, inactive, another) as xs) = function
-       | [] -> xs
-       | Domain.ListAll :: _ -> (true, true, true, false)
-       | Domain.ListActive :: fs -> loop (all, true, inactive, another) fs
-       | Domain.ListInactive :: fs -> loop (all, active, true, another) fs
-       | _ -> (true, true, true, true)
-      in
-      loop (false, false, false, false) flags in
-
-    let active_doms =
-      if get_active then (
-       let n = Connect.num_of_domains conn in
-       let ids = Connect.list_domains conn n in
-       let ids = Array.to_list ids in
-       map_ignore_errors (Domain.lookup_by_id conn) ids
-      ) else [] in
-
-    let inactive_doms =
-      if get_inactive then (
-       let n = Connect.num_of_defined_domains conn in
-       let names = Connect.list_defined_domains conn n in
-       let names = Array.to_list names in
-       map_ignore_errors (Domain.lookup_by_name conn) names
-      ) else [] in
-
-    let doms = active_doms @ inactive_doms in
-
-    if not another_flag then (
-      if want_info then
-       List.split (
-         map_ignore_errors (fun dom -> (dom, Domain.get_info dom)) doms
-       )
-      else
-       doms, []
-    ) else (
-      (* Slow method: We have to get the infos and filter on state. *)
-      let flag_is_set =
-       let h = Hashtbl.create 13 in
-       List.iter (fun flag -> Hashtbl.add h flag ()) flags;
-       Hashtbl.mem h
-      in
-
-      let doms =
-       map_ignore_errors (fun dom -> (dom, Domain.get_info dom)) doms in
-      let doms = List.filter (
-       fun (dom, { Domain.state = state }) ->
-         match state with
-         | Domain.InfoNoState -> flag_is_set Domain.ListNoState
-         | Domain.InfoRunning ->
-             flag_is_set Domain.ListActive || flag_is_set Domain.ListRunning
-         | Domain.InfoBlocked ->
-             flag_is_set Domain.ListActive || flag_is_set Domain.ListBlocked
-         | Domain.InfoPaused ->
-             flag_is_set Domain.ListActive || flag_is_set Domain.ListPaused
-         | Domain.InfoShutdown ->
-             flag_is_set Domain.ListActive || flag_is_set Domain.ListShutdown
-         | Domain.InfoShutoff ->
-             flag_is_set Domain.ListInactive
-             || flag_is_set Domain.ListShutoff
-         | Domain.InfoCrashed -> flag_is_set Domain.ListCrashed
-      ) doms in
-      List.split doms
-    )
-  )
-
 (* Initialization. *)
 external c_init : unit -> unit = "ocaml_libvirt_init"
 let () =

diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index 052d4c0..1dfdc25 100644 (file)
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -79,8 +79,7 @@ let conn = C.connect_readonly ~name ()
 {[
 open Printf
 
-let domains =
-  fst (Libvirt.get_domains conn ~want_info:false [D.ListActive]) in
+let domains = D.get_domains conn [D.ListActive] in
 List.iter (
   fun dom ->
     printf "%8d %s\n%!" (D.get_id dom) (D.get_name dom)
@@ -90,8 +89,7 @@ List.iter (
    {3 Example: List inactive domains}
 
 {[
-let domains =
-  fst (Libvirt.get_domains conn ~want_info:false [D.ListInactive]) in
+let domains = D.get_domains conn [D.ListInactive] in
 List.iter (
   fun dom ->
     printf "inactive %s\n%!" (D.get_name dom)
@@ -157,11 +155,12 @@ printf "uri = %s\n%!" uri
 
     We don't support libvirt < 0.2.1, and never will so don't ask us.
 
-    {3 Get list of domains}
+    {3 Get list of domains and domain infos}
 
     This is a very common operation, and libvirt supports various
     different methods to do it.  We have hidden the complexity in a
-    flexible {!Libvirt.get_domains} call which is easy to use and
+    flexible {!Libvirt.Domain.get_domains} and
+    {!Libvirt.Domain.get_domains_and_infos} calls which is easy to use and
     automatically chooses the most efficient method depending on the
     version of libvirt in use.
 
@@ -309,7 +308,9 @@ sig
 
        Call {!num_of_domains} first to get a value for [max].
 
-       See also: {!Libvirt.get_domains}.
+       See also:
+       {!Libvirt.Domain.get_domains},
+       {!Libvirt.Domain.get_domains_and_infos}.
     *)
   val num_of_domains : [>`R] t -> int
     (** Returns the number of running domains. *)
@@ -324,7 +325,9 @@ sig
 
        Call {!num_of_defined_domains} first to get a value for [max].
 
-       See also: {!Libvirt.get_domains}.
+       See also:
+       {!Libvirt.Domain.get_domains},
+       {!Libvirt.Domain.get_domains_and_infos}.
     *)
   val num_of_networks : [>`R] t -> int
     (** Returns the number of networks. *)
@@ -441,8 +444,6 @@ sig
   type memory_flag = Virtual
 
   type list_flag =
-    | ListNoState | ListRunning | ListBlocked
-    | ListPaused | ListShutdown | ListShutoff | ListCrashed
     | ListActive
     | ListInactive
     | ListAll
@@ -487,9 +488,9 @@ sig
 
        This call was introduced in libvirt 0.4.5.  Because you
        might dynamically link to an older version of libvirt which
-       doesn't have this call, you should use {!Libvirt.get_domains}
-       which uses the most efficient way to get domains for the
-       available version of libvirt.
+       doesn't have this call, you should use {!get_domains}
+       or {!get_domains_and_infos} which use the most efficient
+       way to get domains for the available version of libvirt.
     *)
   val create_linux : [>`W] Connect.t -> xml -> rw t
     (** Create a new guest domain (not necessarily a Linux one)
@@ -635,6 +636,32 @@ sig
     (** [const dom] turns a read/write domain handle into a read-only
        domain handle.  Note that the opposite operation is impossible.
       *)
+
+  val get_domains : ([>`R] as 'a) Connect.t -> list_flag list -> 'a t list
+    (** Get the active and/or inactive domains using the most
+       efficient method available.
+
+       See also:
+       {!get_domains_and_infos},
+       {!list_all_domains},
+       {!Connect.list_domains},
+       {!Connect.list_defined_domains}.
+  *)
+
+  val get_domains_and_infos : ([>`R] as 'a) Connect.t -> list_flag list ->
+    ('a t * info) list
+    (** This gets the active and/or inactive domains and the
+       domain info for each one using the most efficient
+       method available.
+
+       See also:
+       {!get_domains},
+       {!list_all_domains},
+       {!Connect.list_domains},
+       {!Connect.list_defined_domains},
+       {!get_info}.
+    *)
+
 end
   (** Module dealing with domains.  [Domain.t] is the
       domain object. *)
@@ -1067,19 +1094,3 @@ val map_ignore_errors : ('a -> 'b) -> 'a list -> 'b list
     might 'disappear' asynchronously from the currently running
     program.
 *)
-
-val get_domains : ([>`R] as 'a) Connect.t -> ?want_info:bool -> Domain.list_flag list -> 'a Domain.t list * Domain.info list
-  (** Get the active and/or inactive domains using the most
-      efficient method available.
-
-      The two lists returned will have the same length, unless
-      [~want_info] is [false] in which case the info list will be
-      zero-length.  The default for [~want_info] is [true].  In most
-      cases there is no extra penalty for getting the info fields, or
-      the penalty is insignificant.
-
-      See also:
-      {!Domain.list_all_domains},
-      {!Connect.list_domains},
-      {!Connect.list_defined_domains}.
-  *)

diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 4d69bd1..02831da 100644 (file)
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -199,7 +199,8 @@ ocaml_libvirt_connect_node_get_cells_free_memory (value connv,
 extern int virConnectListAllDomains (virConnectPtr conn,
                                      virDomainPtr **domains,
                                      virDomainInfo **infos,
-                                     int stateflags)
+                                     unsigned long stateflags,
+                                     unsigned long flags)
   __attribute__((weak));
 #endif
 #endif
@@ -216,7 +217,8 @@ ocaml_libvirt_connect_list_all_domains (value connv,
   virConnectPtr conn = Connect_val (connv);
   virDomainPtr *domains;
   virDomainInfo *infos;
-  int want_info, i, r, flag, flags = 0;
+  int want_info, i, r, flag;
+  unsigned long flags = 0;
 
   /* ?want_info */
   if (wantinfov == Val_int (0)) /* None == true */
@@ -229,23 +231,16 @@ ocaml_libvirt_connect_list_all_domains (value connv,
     flagv = Field (flagsv, 0);
     flag = Int_val (flagv);
     switch (flag) {
-    case 0: flags |= VIR_DOMAIN_LIST_NOSTATE; break;
-    case 1: flags |= VIR_DOMAIN_LIST_RUNNING; break;
-    case 2: flags |= VIR_DOMAIN_LIST_BLOCKED; break;
-    case 3: flags |= VIR_DOMAIN_LIST_PAUSED; break;
-    case 4: flags |= VIR_DOMAIN_LIST_SHUTDOWN; break;
-    case 5: flags |= VIR_DOMAIN_LIST_SHUTOFF; break;
-    case 6: flags |= VIR_DOMAIN_LIST_CRASHED; break;
-    case 7: flags |= VIR_DOMAIN_LIST_ACTIVE; break;
-    case 8: flags |= VIR_DOMAIN_LIST_INACTIVE; break;
-    case 9: flags |= VIR_DOMAIN_LIST_ALL; break;
+    case 0: flags |= VIR_DOMAIN_LIST_ACTIVE; break;
+    case 1: flags |= VIR_DOMAIN_LIST_INACTIVE; break;
+    case 2: flags |= VIR_DOMAIN_LIST_ALL; break;
     }
   }
 
   WEAK_SYMBOL_CHECK (virConnectListAllDomains);
   NONBLOCKING (r = virConnectListAllDomains (conn, &domains,
                                              want_info ? &infos : NULL,
-                                             flags));
+                                             flags, 0));
   CHECK_ERROR (r == -1, conn, "virConnectListAllDomains");
 
   /* Convert the result into a pair of arrays. */

diff --git a/mlvirsh/mlvirsh.ml b/mlvirsh/mlvirsh.ml
index 9fd3779..acb6a51 100644 (file)
--- a/mlvirsh/mlvirsh.ml
+++ b/mlvirsh/mlvirsh.ml
@@ -579,14 +579,14 @@ let do_command =
       cmd0 print_domain_list
        (fun () ->
           let c = get_readonly_connection () in
-          fst (Libvirt.get_domains c ~want_info:false [D.ListActive])),
+          D.get_domains c [D.ListActive]),
       s_"List the running domains.",
       [];
     "list-defined",
       cmd0 print_domain_list
        (fun () ->
           let c = get_readonly_connection () in
-          fst (Libvirt.get_domains c ~want_info:false [D.ListInactive])),
+          D.get_domains c [D.ListInactive]),
       s_"List the defined but not running domains.",
       [];
     "quit",