From: Richard W.M. Jones <"Richard W.M. Jones "> Date: Wed, 3 Sep 2008 15:27:43 +0000 (+0100) Subject: Implement version 3 of virConnectListAllDomains. X-Git-Tag: 0.6.1.1~14 X-Git-Url: http://git.annexia.org/?p=ocaml-libvirt.git;a=commitdiff_plain;h=40a01d1ac4c73496e06944fc1910694908f3442d Implement version 3 of virConnectListAllDomains. --- diff --git a/examples/list_domains.ml b/examples/list_domains.ml index 2e9e436..6b04932 100644 --- 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 --- 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 --- 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 --- 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 --- 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",