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
 
 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 =
 let () =
   try
     let name =


@@ -19,21 +28,16 @@ let () =
        None in
     let conn = C.connect_readonly ?name () in
 
        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 (
     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)
   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
 
   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
 module Domain =
 struct
   type 'rw t


@@ -141,8 +348,6 @@ struct
   type memory_flag = Virtual
 
   type list_flag =
   type memory_flag = Virtual
 
   type list_flag =

-    | ListNoState | ListRunning | ListBlocked
-    | ListPaused | ListShutdown | ListShutoff | ListCrashed

     | ListActive
     | ListInactive
     | ListAll
     | 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"
   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 =
 end
 
 module Network =


@@ -335,306 +629,6 @@ struct
   external const : ('a, [>`R]) t -> ('a, ro) t = "%identity"
 end
 
   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 () =
 (* 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
 
 {[
 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)
 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}
 
 {[
    {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)
 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.
 
 
     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
 
     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.
 
     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].
 
 
        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. *)
     *)
   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].
 
 
        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. *)
     *)
   val num_of_networks : [>`R] t -> int
     (** Returns the number of networks. *)


@@ -441,8 +444,6 @@ sig
   type memory_flag = Virtual
 
   type list_flag =
   type memory_flag = Virtual
 
   type list_flag =

-    | ListNoState | ListRunning | ListBlocked
-    | ListPaused | ListShutdown | ListShutoff | ListCrashed

     | ListActive
     | ListInactive
     | ListAll
     | 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
 
        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)
     *)
   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.
       *)
     (** [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. *)
 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.
 *)
     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,
 extern int virConnectListAllDomains (virConnectPtr conn,
                                      virDomainPtr **domains,
                                      virDomainInfo **infos,

-                                     int stateflags)
+                                     unsigned long stateflags,
+                                     unsigned long flags)

   __attribute__((weak));
 #endif
 #endif
   __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;
   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 */
 
   /* ?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) {
     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,
     }
   }
 
   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. */
   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
       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
       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",
       s_"List the defined but not running domains.",
       [];
     "quit",