X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=libvirt%2Flibvirt.ml;h=1e37136e4a061096eafa1c1d5cbb5d61fb3fbd2f;hb=4d988dada41d62c5f40a24c69220184ff6b079e0;hp=3f48430c6b258f2ac5e637ca1abc921958771a34;hpb=0f9e3596a93f7792fdc0eb7faccabd0d32493749;p=ocaml-libvirt.git diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml index 3f48430..1e37136 100644 --- a/libvirt/libvirt.ml +++ b/libvirt/libvirt.ml @@ -5,14 +5,17 @@ This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. + version 2 of the License, or (at your option) any later version, + with the OCaml linking exception described in ../COPYING.LIB. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. - Please see the file ../COPYING.LIB. + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA *) type uuid = string @@ -47,6 +50,13 @@ struct threads : int; } + type list_flag = + | ListNoState | ListRunning | ListBlocked + | ListPaused | ListShutdown | ListShutoff | ListCrashed + | ListActive + | ListInactive + | ListAll + external connect : ?name:string -> unit -> rw t = "ocaml_libvirt_connect_open" external connect_readonly : ?name:string -> unit -> ro t = "ocaml_libvirt_connect_open_readonly" external close : [>`R] t -> unit = "ocaml_libvirt_connect_close" @@ -130,6 +140,13 @@ struct type memory_flag = Virtual + type list_flag = + | ListNoState | ListRunning | ListBlocked + | ListPaused | ListShutdown | ListShutoff | ListCrashed + | ListActive + | ListInactive + | ListAll + type block_stats = { rd_req : int64; rd_bytes : int64; @@ -149,6 +166,14 @@ struct tx_drop : int64; } + (* The maximum size for Domain.memory_peek and Domain.block_peek + * supported by libvirt. This may change with different versions + * of libvirt in the future, hence it's a function. + *) + let max_peek _ = 65536 + + external list_all_domains : 'a Connect.t -> ?want_info:bool -> list_flag list -> 'a t array * info array = "ocaml_libvirt_connect_list_all_domains" + external create_linux : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_domain_create_linux" external create_linux_job : [>`W] Connect.t -> xml -> ([`Domain], rw) job_t = "ocaml_libvirt_domain_create_linux_job" external lookup_by_id : 'a Connect.t -> int -> 'a t = "ocaml_libvirt_domain_lookup_by_id" @@ -511,6 +536,105 @@ 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 () =