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
type memory_flag = Virtual
type list_flag =
- | ListNoState | ListRunning | ListBlocked
- | ListPaused | ListShutdown | ListShutoff | ListCrashed
| ListActive
| ListInactive
| ListAll
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 =
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 () =
git.annexia.org / ocaml-libvirt.git / blobdiff