From d445e4f54fcfd19a98451eb0b5b5b5237bf9df78 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 7 Jan 2008 22:53:34 +0000 Subject: mlvirtmanager renamed as virt-ctrl. * .hgignore, Makefile.in, configure.ac: Rename mlvirtmanager as virt-ctrl to avoid any confusion with the real virt-manager. * mlvirtmanager/, virt-ctrl/: Subdirectory moved. * README: Supporting documentation updated. --- mlvirtmanager/.depend | 22 -- mlvirtmanager/Makefile.in | 87 -------- mlvirtmanager/mlvirtmanager.ml | 32 --- mlvirtmanager/mlvirtmanager_connections.ml | 326 ---------------------------- mlvirtmanager/mlvirtmanager_connections.mli | 47 ---- mlvirtmanager/mlvirtmanager_domain_ops.ml | 96 -------- mlvirtmanager/mlvirtmanager_domain_ops.mli | 25 --- mlvirtmanager/mlvirtmanager_helpers.ml | 95 -------- mlvirtmanager/mlvirtmanager_helpers.mli | 51 ----- mlvirtmanager/mlvirtmanager_mainwindow.ml | 147 ------------- mlvirtmanager/mlvirtmanager_mainwindow.mli | 29 --- 11 files changed, 957 deletions(-) delete mode 100755 mlvirtmanager/.depend delete mode 100644 mlvirtmanager/Makefile.in delete mode 100755 mlvirtmanager/mlvirtmanager.ml delete mode 100755 mlvirtmanager/mlvirtmanager_connections.ml delete mode 100755 mlvirtmanager/mlvirtmanager_connections.mli delete mode 100755 mlvirtmanager/mlvirtmanager_domain_ops.ml delete mode 100755 mlvirtmanager/mlvirtmanager_domain_ops.mli delete mode 100755 mlvirtmanager/mlvirtmanager_helpers.ml delete mode 100755 mlvirtmanager/mlvirtmanager_helpers.mli delete mode 100755 mlvirtmanager/mlvirtmanager_mainwindow.ml delete mode 100755 mlvirtmanager/mlvirtmanager_mainwindow.mli (limited to 'mlvirtmanager') diff --git a/mlvirtmanager/.depend b/mlvirtmanager/.depend deleted file mode 100755 index 01a1aa6..0000000 --- a/mlvirtmanager/.depend +++ /dev/null @@ -1,22 +0,0 @@ -mlvirtmanager_connections.cmi: ../libvirt/libvirt.cmi -mlvirtmanager_domain_ops.cmi: mlvirtmanager_connections.cmi -mlvirtmanager_helpers.cmi: ../libvirt/libvirt.cmi -mlvirtmanager_mainwindow.cmi: mlvirtmanager_connections.cmi -mlvirtmanager_connections.cmo: mlvirtmanager_helpers.cmi \ - ../libvirt/libvirt.cmi mlvirtmanager_connections.cmi -mlvirtmanager_connections.cmx: mlvirtmanager_helpers.cmx \ - ../libvirt/libvirt.cmx mlvirtmanager_connections.cmi -mlvirtmanager_domain_ops.cmo: mlvirtmanager_connections.cmi \ - ../libvirt/libvirt.cmi mlvirtmanager_domain_ops.cmi -mlvirtmanager_domain_ops.cmx: mlvirtmanager_connections.cmx \ - ../libvirt/libvirt.cmx mlvirtmanager_domain_ops.cmi -mlvirtmanager_helpers.cmo: ../libvirt/libvirt.cmi mlvirtmanager_helpers.cmi -mlvirtmanager_helpers.cmx: ../libvirt/libvirt.cmx mlvirtmanager_helpers.cmi -mlvirtmanager_mainwindow.cmo: mlvirtmanager_connections.cmi \ - ../libvirt/libvirt.cmi mlvirtmanager_mainwindow.cmi -mlvirtmanager_mainwindow.cmx: mlvirtmanager_connections.cmx \ - ../libvirt/libvirt.cmx mlvirtmanager_mainwindow.cmi -mlvirtmanager.cmo: mlvirtmanager_mainwindow.cmi mlvirtmanager_domain_ops.cmi \ - mlvirtmanager_connections.cmi -mlvirtmanager.cmx: mlvirtmanager_mainwindow.cmx mlvirtmanager_domain_ops.cmx \ - mlvirtmanager_connections.cmx diff --git a/mlvirtmanager/Makefile.in b/mlvirtmanager/Makefile.in deleted file mode 100644 index b9bf280..0000000 --- a/mlvirtmanager/Makefile.in +++ /dev/null @@ -1,87 +0,0 @@ -# mlvirtmanager -# Copyright (C) 2007 Red Hat Inc., Richard W.M. Jones -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program 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 General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -INSTALL := @INSTALL@ - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -bindir = @bindir@ - -OCAMLFIND = @OCAMLFIND@ - -ifneq ($(OCAMLFIND),) -OCAMLCPACKAGES := -package unix,lablgtk2 -I ../libvirt -OCAMLCFLAGS := -g -OCAMLCLIBS := -linkpkg -OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) -OCAMLOPTFLAGS := -OCAMLOPTLIBS := $(OCAMLCLIBS) -else -OCAMLCINCS := -I @pkg_lablgtk2@ -I ../libvirt -OCAMLCFLAGS := -g -OCAMLCLIBS := unix.cma lablgtk.cma -OCAMLOPTINCS := $(OCAMLCINCS) -OCAMLOPTFLAGS := -OCAMLOPTLIBS := unix.cmxa lablgtk.cmxa -endif - -export LIBRARY_PATH=../libvirt -export LD_LIBRARY_PATH=../libvirt - -BYTE_TARGETS := mlvirtmanager -OPT_TARGETS := mlvirtmanager.opt - -VIRTMANAGER_OBJS := \ - mlvirtmanager_helpers.cmo \ - mlvirtmanager_connections.cmo \ - mlvirtmanager_domain_ops.cmo \ - mlvirtmanager_mainwindow.cmo \ - mlvirtmanager.cmo - -VIRTMANAGER_XOBJS := $(VIRTMANAGER_OBJS:.cmo=.cmx) - -all: $(BYTE_TARGETS) - -opt: $(OPT_TARGETS) - -ifneq ($(OCAMLFIND),) -mlvirtmanager: $(VIRTMANAGER_OBJS) - $(OCAMLFIND) ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma gtkInit.cmo -o $@ $^ - -mlvirtmanager.opt: $(VIRTMANAGER_XOBJS) - $(OCAMLFIND) ocamlopt \ - $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $^ -else -mlvirtmanager: $(VIRTMANAGER_OBJS) - $(OCAMLC) $(OCAMLCINCS) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma gtkInit.cmo -o $@ $^ - -mlvirtmanager.opt: $(VIRTMANAGER_XOBJS) - $(OCAMLOPT) -verbose $(OCAMLOPTINCS) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - -cclib "$(LDFLAGS)" \ - ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $^ -endif - -install: - if [ -x mlvirtmanager.opt ]; then \ - mkdir -p $(DESTDIR)$(bindir); \ - $(INSTALL) -m 0755 mlvirtmanager.opt $(DESTDIR)$(bindir)/mlvirtmanager; \ - fi - -include ../Make.rules diff --git a/mlvirtmanager/mlvirtmanager.ml b/mlvirtmanager/mlvirtmanager.ml deleted file mode 100755 index 12382fe..0000000 --- a/mlvirtmanager/mlvirtmanager.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* virt-manager-like graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program 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 General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -*) - -open Printf - -let () = - (* Build the main window and wire up the buttons to the callback functions *) - Mlvirtmanager_mainwindow.make - ~open_connection:Mlvirtmanager_connections.open_connection - ~start_domain:Mlvirtmanager_domain_ops.start_domain - ~pause_domain:Mlvirtmanager_domain_ops.pause_domain - ~resume_domain:Mlvirtmanager_domain_ops.resume_domain - ~shutdown_domain:Mlvirtmanager_domain_ops.shutdown_domain; - - (* Enter the Gtk main loop. *) - GMain.main () diff --git a/mlvirtmanager/mlvirtmanager_connections.ml b/mlvirtmanager/mlvirtmanager_connections.ml deleted file mode 100755 index e72ffcd..0000000 --- a/mlvirtmanager/mlvirtmanager_connections.ml +++ /dev/null @@ -1,326 +0,0 @@ -(* virt-manager-like graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program 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 General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -*) - -open Printf - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -open Mlvirtmanager_helpers - -(* List of currently open connections. Actually it's a list of - * (id, Libvirt.Connect.t) so that we can easily identify - * connections by their unique ID. - *) -let get_conns, add_conn, del_conn = - let conns = ref [] in - let id = ref 0 in - let get_conns () = !conns in - let add_conn conn = - incr id; let id = !id in - conns := (id, conn) :: !conns; - id - in - let del_conn id = - conns := List.filter (fun (id', _) -> id <> id') !conns - in - get_conns, add_conn, del_conn - -(* The current state. This is used so that we can see changes that - * have happened and add or remove parts of the model. (Previously - * we used to recreate the whole model each time, but the problem - * with that is we "forget" things like the selection). - *) -type state = connection list -and connection = int (* connection ID *) * (active list * inactive list) -and active = int (* domain's ID *) -and inactive = string (* domain's name *) - -(* The last "CPU time" seen for a domain, so we can calculate CPU % usage. - * Hash of (connid, domid) -> cpu_time [int64]. - *) -let last_cpu_time = Hashtbl.create 13 -let last_time = ref (Unix.gettimeofday ()) - -type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column - -let debug_repopulate = true - -(* Populate the tree with the current list of connections, domains. - * This function is called once per second. - *) -let repopulate (tree : GTree.view) (model : GTree.tree_store) - (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id) - state = - let time_passed = - let time_now = Unix.gettimeofday () in - let time_passed = time_now -. !last_time in - last_time := time_now; - time_passed in - - (* Which connections have been added or removed? *) - let conns = get_conns () in - let added, _, removed = - let old_conn_ids = List.map fst state - and new_conn_ids = List.map fst conns in - differences old_conn_ids new_conn_ids in - - (* Remove the subtrees for any connections which have gone. *) - if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed; - - List.iter ( - fun conn_id -> - filter_top_level_rows model - (fun row -> conn_id <> model#get ~row ~column:col_id) - ) removed; - - (* Add placeholder subtree for any new connections. *) - if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added; - - List.iter ( - fun conn_id -> - let row = model#append () in - (* Get the connection name. *) - let name = - try C.get_hostname (List.assoc conn_id conns) - with Not_found | Libvirt.Virterror _ -> - "Conn #" ^ string_of_int conn_id in - model#set ~row ~column:col_name_id name; - model#set ~row ~column:col_id conn_id; - (* XXX This doesn't work, why? *) - tree#expand_row (model#get_path row) - ) added; - - let new_state = - List.map ( - fun (conn_id, conn) -> - (* Get the old list of active and inactive domains. If this - * connection is newly created, start with empty lists. - *) - let old_active, old_inactive = - try List.assoc conn_id state - with Not_found -> [], [] in - - (* Get the top level row in the model corresponding to this - * connection. - *) - let parent = - try find_top_level_row model - (fun row -> conn_id = model#get ~row ~column:col_id) - with Not_found -> assert false (* Should never happen. *) in - - try - (* Node info & number of CPUs available. *) - let node_info = C.get_node_info conn in - let nr_cpus = C.maxcpus_of_node_info node_info in - - (* For this connection, get a current list of active domains (IDs) *) - let active = - let n = C.num_of_domains conn in - let doms = C.list_domains conn n in - Array.to_list doms in - - (* Which active domains have been added or removed? *) - let added, _, removed = differences old_active active in - - (* Remove any active domains which have disappeared. *) - if debug_repopulate then - List.iter (eprintf "-active %d\n%!") removed; - - List.iter ( - fun domid -> - filter_rows model - (fun row -> domid <> model#get ~row ~column:col_id) - (model#iter_children (Some parent)) - ) removed; - - (* Add any active domains which have appeared. *) - if debug_repopulate then - List.iter (eprintf "+active %d\n%!") added; - - List.iter ( - fun domid -> - let domname = - try - let dom = D.lookup_by_id conn domid in - D.get_name dom - with _ -> "" in (* Ignore any transient error. *) - - let row = model#append ~parent () in - model#set ~row ~column:col_name_id (string_of_int domid); - model#set ~row ~column:col_domname domname; - model#set ~row ~column:col_id domid - ) added; - - (* Get a current list of inactive domains (names). *) - let inactive = - let n = C.num_of_defined_domains conn in - let doms = C.list_defined_domains conn n in - Array.to_list doms in - - (* Which inactive domains have been added or removed? *) - let added, _, removed = differences old_inactive inactive in - - (* Remove any inactive domains which have disappeared. *) - if debug_repopulate then - List.iter (eprintf "-inactive %s\n%!") removed; - - List.iter ( - fun domname -> - filter_rows model - (fun row -> - model#get ~row ~column:col_id <> -1 || - model#get ~row ~column:col_domname <> domname) - (model#iter_children (Some parent)) - ) removed; - - (* Add any inactive domains which have appeared. *) - if debug_repopulate then - List.iter (eprintf "+inactive %s\n%!") added; - - List.iter ( - fun domname -> - let row = model#append ~parent () in - model#set ~row ~column:col_name_id ""; - model#set ~row ~column:col_domname domname; - model#set ~row ~column:col_status "inactive"; - model#set ~row ~column:col_id (-1) - ) added; - - (* Now iterate over all active domains and update their state, - * CPU and memory. - *) - iter_rows model ( - fun row -> - let domid = model#get ~row ~column:col_id in - if domid >= 0 then ( (* active *) - try - let dom = D.lookup_by_id conn domid in - let info = D.get_info dom in - let status = string_of_domain_state info.D.state in - model#set ~row ~column:col_status status; - let memory = sprintf "%Ld K" info.D.memory in - model#set ~row ~column:col_mem memory; - - let ns_now = info.D.cpu_time in (* ns = nanoseconds *) - let ns_prev = - try - let ns = Hashtbl.find last_cpu_time (conn_id, domid) in - if ns > ns_now then 0L else ns (* Rebooted? *) - with Not_found -> 0L in - Hashtbl.replace last_cpu_time (conn_id, domid) ns_now; - let ns_now = Int64.to_float ns_now in - let ns_prev = Int64.to_float ns_prev in - let ns_used = ns_now -. ns_prev in - let ns_available = 1_000_000_000. *. float nr_cpus in - let cpu_percent = - 100. *. (ns_used /. ns_available) /. time_passed in - let cpu_percent = sprintf "%.1f %%" cpu_percent in - model#set ~row ~column:col_cpu cpu_percent; - - with Libvirt.Virterror _ -> () (* Ignore any transient error *) - ) - ) (model#iter_children (Some parent)); - - (* Return new state. *) - conn_id, (active, inactive) - with - (* Libvirt errors here are not really fatal. They can happen - * if the state changes at the moment we read it. If it does - * happen, just return the old state, and next time we come - * around to this connection it'll be fixed. - *) - | Libvirt.Virterror err -> - prerr_endline (Libvirt.Virterror.to_string err); - conn_id, (old_active, old_inactive) - | Failure msg -> - prerr_endline msg; - conn_id, (old_active, old_inactive) - ) conns in - - (* Return the updated state. *) - new_state - -(* Make the treeview which displays the connections and domains. *) -let make_treeview ?packing () = - let cols = new GTree.column_list in - let col_name_id = cols#add Gobject.Data.string in - let col_domname = cols#add Gobject.Data.string in - let col_status = cols#add Gobject.Data.string in - let col_cpu = cols#add Gobject.Data.string in - let col_mem = cols#add Gobject.Data.string in - (* Hidden column containing the connection ID or domain ID. For - * inactive domains, this contains -1 and col_domname is the name. *) - let col_id = cols#add Gobject.Data.int in - let model = GTree.tree_store cols in - - (* Column sorting functions. *) - let make_sort_func_on column = - fun (model : GTree.model) row1 row2 -> - let col1 = model#get ~row:row1 ~column in - let col2 = model#get ~row:row2 ~column in - compare col1 col2 - in - (*model#set_default_sort_func (make_sort_func_on col_domname);*) - model#set_sort_func 0 (make_sort_func_on col_name_id); - model#set_sort_func 1 (make_sort_func_on col_domname); - model#set_sort_column_id 1 `ASCENDING; - - (* Make the GtkTreeView and attach column renderers to it. *) - let tree = GTree.view ~model ~reorderable:false ?packing () in - - let append_visible_column title column sort = - let renderer = GTree.cell_renderer_text [], ["text", column] in - let view_col = GTree.view_column ~title ~renderer () in - ignore (tree#append_column view_col); - match sort with - | None -> () - | Some (sort_indicator, sort_order, sort_column_id) -> - view_col#set_sort_indicator sort_indicator; - view_col#set_sort_order sort_order; - view_col#set_sort_column_id sort_column_id - in - append_visible_column "ID" col_name_id (Some (false, `ASCENDING, 0)); - append_visible_column "Name" col_domname (Some (true, `ASCENDING, 1)); - append_visible_column "Status" col_status None; - append_visible_column "CPU" col_cpu None; - append_visible_column "Memory" col_mem None; - - let columns = - col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in - let state = repopulate tree model columns [] in - - (tree, model, columns, state) - -(* Callback function to open a connection. - * This should be a lot more sophisticated. XXX - *) -let open_connection () = - let title = "Open connection to hypervisor" in - let name = - GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in - match name with - | None -> () - | Some name -> - (* If this fails, let the exception escape and be printed - * in the global exception handler. - *) - let conn = C.connect ~name () in - ignore (add_conn conn) diff --git a/mlvirtmanager/mlvirtmanager_connections.mli b/mlvirtmanager/mlvirtmanager_connections.mli deleted file mode 100755 index 7d4102c..0000000 --- a/mlvirtmanager/mlvirtmanager_connections.mli +++ /dev/null @@ -1,47 +0,0 @@ -(* virt-manager-like graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program 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 General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - Handle connections and the complicated GtkTreeView which - displays the connections / domains. -*) - -(** Get the list of current connections. *) -val get_conns : unit -> (int * Libvirt.rw Libvirt.Connect.t) list - -(** The current/previous state last time repopulate was called. The - repopulate function uses this state to determine what has changed - (eg. domains added, removed) since last time. -*) -type state - -type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column - -(** This function should be called once per second in order to - redraw the GtkTreeView. - - Takes the previous state as a parameter and returns the new state. -*) -val repopulate : GTree.view -> GTree.tree_store -> columns -> state -> state - -(** Create the GtkTreeView. Returns the widget itself, the model, - the list of columns, and the initial state. -*) -val make_treeview : ?packing:(GObj.widget -> unit) -> unit -> GTree.view * GTree.tree_store * columns * state - -(** This callback creates the Connect to hypervisor dialog. *) -val open_connection : unit -> unit diff --git a/mlvirtmanager/mlvirtmanager_domain_ops.ml b/mlvirtmanager/mlvirtmanager_domain_ops.ml deleted file mode 100755 index 6de6c59..0000000 --- a/mlvirtmanager/mlvirtmanager_domain_ops.ml +++ /dev/null @@ -1,96 +0,0 @@ -(* virt-manager-like graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program 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 General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - Domain operations buttons. -*) - -open Printf - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -(* Get the selected domain (if there is one) or return None. *) -let get_domain (tree : GTree.view) (model : GTree.tree_store) - (columns : Mlvirtmanager_connections.columns) = - let path, _ = tree#get_cursor () in - match path with - | None -> None (* No row at all selected. *) - | Some path -> - let row = model#get_iter path in - (* Visit parent to get the conn_id. - * If this returns None, then it's a top-level row which is - * selected (ie. a connection), so just ignore. - *) - match model#iter_parent row with - | None -> None - | Some parent -> - try - let (_, col_domname, _, _, _, col_id) = columns in - let conn_id = model#get ~row:parent ~column:col_id in - let conn = - List.assoc conn_id (Mlvirtmanager_connections.get_conns ()) in - let domid = model#get ~row ~column:col_id in - if domid = -1 then ( (* Inactive domain. *) - let domname = model#get ~row ~column:col_domname in - let dom = D.lookup_by_name conn domname in - let info = D.get_info dom in - Some (dom, info, -1) - ) else if domid > 0 then ( (* Active domU. *) - let dom = D.lookup_by_id conn domid in - let info = D.get_info dom in - Some (dom, info, domid) - ) else (* Dom0 - ignore. *) - None - with - (* Domain or connection disappeared under us. *) - | Not_found -> None - | Failure msg -> - prerr_endline msg; - None - | Libvirt.Virterror err -> - prerr_endline (Libvirt.Virterror.to_string err); - None - -let start_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, _, domid) -> - if domid = -1 then - D.create dom - -let pause_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, domid) -> - if domid >= 0 && info.D.state <> D.InfoPaused then - D.suspend dom - -let resume_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, domid) -> - if domid >= 0 && info.D.state = D.InfoPaused then - D.resume dom - -let shutdown_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, domid) -> - if domid >= 0 && info.D.state <> D.InfoShutdown then - D.shutdown dom diff --git a/mlvirtmanager/mlvirtmanager_domain_ops.mli b/mlvirtmanager/mlvirtmanager_domain_ops.mli deleted file mode 100755 index fd1bfc9..0000000 --- a/mlvirtmanager/mlvirtmanager_domain_ops.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* virt-manager-like graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program 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 General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - Domain operations buttons. -*) - -val start_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit -val pause_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit -val resume_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit -val shutdown_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit diff --git a/mlvirtmanager/mlvirtmanager_helpers.ml b/mlvirtmanager/mlvirtmanager_helpers.ml deleted file mode 100755 index 859b8f2..0000000 --- a/mlvirtmanager/mlvirtmanager_helpers.ml +++ /dev/null @@ -1,95 +0,0 @@ -(* virt-manager-like graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program 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 General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -*) - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -(* Given two lists, xs and ys, return a list of items which have been - * added to ys, items which are the same, and items which have been - * removed from ys. - * Returns a triplet (list of added, list of same, list of removed). - *) -let differences xs ys = - let rec d = function - | [], [] -> (* Base case. *) - ([], [], []) - | [], ys -> (* All ys have been added. *) - (ys, [], []) - | xs, [] -> (* All xs have been removed. *) - ([], [], xs) - | (x :: xs), (y :: ys) when x = y -> (* Not added or removed. *) - let added, unchanged, removed = d (xs, ys) in - added, x :: unchanged, removed - | (x :: xs), ((y :: _) as ys) when x < y -> (* x removed. *) - let added, unchanged, removed = d (xs, ys) in - added, unchanged, x :: removed - | ((x :: _) as xs), (y :: ys) (* when x > y *) -> (* y added. *) - let added, unchanged, removed = d (xs, ys) in - y :: added, unchanged, removed - in - d (List.sort compare xs, List.sort compare ys) - -let string_of_domain_state = function - | D.InfoNoState -> "unknown" - | D.InfoRunning -> "running" - | D.InfoBlocked -> "blocked" - | D.InfoPaused -> "paused" - | D.InfoShutdown -> "shutdown" - | D.InfoShutoff -> "shutoff" - | D.InfoCrashed -> "crashed" - -(* Filter top level rows (only) in a tree_store. If function f returns - * true then the row remains, but if it returns false then the row is - * removed. - *) -let rec filter_top_level_rows (model : GTree.tree_store) f = - match model#get_iter_first with - | None -> () - | Some iter -> filter_rows model f iter - -(* Filter rows in a tree_store at a particular level. *) -and filter_rows model f row = - let keep = f row in - let iter_still_valid = - if not keep then model#remove row else model#iter_next row in - if iter_still_valid then filter_rows model f row - -(* Find the first top level row matching predicate f and return it. *) -let rec find_top_level_row (model : GTree.tree_store) f = - match model#get_iter_first with - | None -> raise Not_found (* no rows *) - | Some row -> find_row model f row - -(* Find the first row matching predicate f at a particular level. *) -and find_row model f row = - if f row then row - else if model#iter_next row then find_row model f row - else raise Not_found - -(* Iterate over top level rows (only) in a tree_store. *) -let rec iter_top_level_rows (model : GTree.tree_store) f = - match model#get_iter_first with - | None -> () - | Some iter -> iter_rows model f iter - -(* Iterate over rows in a tree_store at a particular level. *) -and iter_rows model f row = - f row; - if model#iter_next row then iter_rows model f row diff --git a/mlvirtmanager/mlvirtmanager_helpers.mli b/mlvirtmanager/mlvirtmanager_helpers.mli deleted file mode 100755 index 25c5417..0000000 --- a/mlvirtmanager/mlvirtmanager_helpers.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* virt-manager-like graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program 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 General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - Helper functions. -*) - -(** Given two lists, xs and ys, return a list of items which have been - added to ys, items which are the same, and items which have been - removed from ys. - Returns a triplet (list of added, list of same, list of removed). -*) -val differences : 'a list -> 'a list -> 'a list * 'a list * 'a list - -(** Convert libvirt domain state to a string. *) -val string_of_domain_state : Libvirt.Domain.state -> string - -(** Filter top level rows (only) in a GtkTreeStore. If function f returns - true then the row remains, but if it returns false then the row is - removed. -*) -val filter_top_level_rows : GTree.tree_store -> (Gtk.tree_iter -> bool) -> unit - -(** Filter rows in a tree_store at a particular level. *) -val filter_rows : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter -> unit - -(** Find the first top level row matching predicate and return it. *) -val find_top_level_row : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter - -(** Find the first row matching predicate f at a particular level. *) -val find_row : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter -> Gtk.tree_iter - -(** Iterate over top level rows (only) in a GtkTreeStore. *) -val iter_top_level_rows : GTree.tree_store -> (Gtk.tree_iter -> unit) -> unit - -(** Iterate over rows in a tree_store at a particular level. *) -val iter_rows : GTree.tree_store -> (Gtk.tree_iter -> unit) -> Gtk.tree_iter -> unit diff --git a/mlvirtmanager/mlvirtmanager_mainwindow.ml b/mlvirtmanager/mlvirtmanager_mainwindow.ml deleted file mode 100755 index 918c9a6..0000000 --- a/mlvirtmanager/mlvirtmanager_mainwindow.ml +++ /dev/null @@ -1,147 +0,0 @@ -(* virt-manager-like graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program 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 General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -*) - -open Printf - -let title = "Virtual Machine Manager" - -let utf8_copyright = "\194\169" - -let help_about () = - let gtk_version = - let gtk_major, gtk_minor, gtk_micro = GMain.Main.version in - sprintf "%d.%d.%d" gtk_major gtk_minor gtk_micro in - let virt_version = string_of_int (fst (Libvirt.get_version ())) in - let title = "About " ^ title in - let icon = GMisc.image () in - icon#set_stock `DIALOG_INFO; - icon#set_icon_size `DIALOG; - GToolbox.message_box - ~title - ~icon - ("Virtual machine manager (OCaml version) by\n" ^ - "Richard W.M. Jones (rjones@redhat.com).\n\n" ^ - "Copyright " ^ utf8_copyright ^ " 2007 Red Hat Inc.\n\n" ^ - "Libvirt version: " ^ virt_version ^ "\n" ^ - "Gtk toolkit version: " ^ gtk_version) - -(* Catch any exception and throw up a dialog. *) -let () = - (* A nicer exception printing function. *) - let string_of_exn = function - | Libvirt.Virterror err -> - "Virtualisation error: " ^ (Libvirt.Virterror.to_string err) - | Failure msg -> msg - | exn -> Printexc.to_string exn - in - GtkSignal.user_handler := - fun exn -> - let label = string_of_exn exn in - let title = "Error" in - let icon = GMisc.image () in - icon#set_stock `DIALOG_ERROR; - icon#set_icon_size `DIALOG; - GToolbox.message_box ~title ~icon label - -let make ~open_connection - ~start_domain ~pause_domain ~resume_domain ~shutdown_domain = - (* Create the main window. *) - let window = GWindow.window ~width:800 ~height:600 ~title () in - let vbox = GPack.vbox ~packing:window#add () in - - (* Menu bar. *) - let menubar = GMenu.menu_bar ~packing:vbox#pack () in - let factory = new GMenu.factory menubar in - let accel_group = factory#accel_group in - let file_menu = factory#add_submenu "File" in - let help_menu = factory#add_submenu "Help" in - - (* File menu. *) - let factory = new GMenu.factory file_menu ~accel_group in - let open_item = factory#add_item "Open connection ..." - ~key:GdkKeysyms._O in - ignore (factory#add_separator ()); - let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in - - ignore (open_item#connect#activate ~callback:open_connection); - - (* Help menu. *) - let factory = new GMenu.factory help_menu ~accel_group in - let help_item = factory#add_item "Help" in - let help_about_item = factory#add_item "About ..." in - - ignore (help_about_item#connect#activate ~callback:help_about); - - (* The toolbar. *) - let toolbar = GButton.toolbar ~packing:vbox#pack () in - let connect_button = - GButton.tool_button ~label:"Connect ..." ~stock:`CONNECT - ~packing:toolbar#insert () in - let start_button = - GButton.tool_button ~label:"Start" ~stock:`ADD - ~packing:toolbar#insert () in - let pause_button = - GButton.tool_button ~label:"Pause" ~stock:`MEDIA_PAUSE - ~packing:toolbar#insert () in - let resume_button = - GButton.tool_button ~label:"Resume" ~stock:`MEDIA_PLAY - ~packing:toolbar#insert () in - let shutdown_button = - GButton.tool_button ~label:"Shutdown" ~stock:`STOP - ~packing:toolbar#insert () in - ignore (connect_button#connect#clicked ~callback:open_connection); - - (* The treeview. *) - let (tree, model, columns, initial_state) = - Mlvirtmanager_connections.make_treeview - ~packing:(vbox#pack ~expand:true ~fill:true) () in - - ignore (start_button#connect#clicked - ~callback:(start_domain tree model columns)); - ignore (pause_button#connect#clicked - ~callback:(pause_domain tree model columns)); - ignore (resume_button#connect#clicked - ~callback:(resume_domain tree model columns)); - ignore (shutdown_button#connect#clicked - ~callback:(shutdown_domain tree model columns)); - - (* Make a timeout function which is called once per second. *) - let state = ref initial_state in - let callback () = - state := Mlvirtmanager_connections.repopulate tree model columns !state; - true - in - let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in - - (* Quit. *) - let quit _ = - GMain.Timeout.remove timeout_id; - GMain.Main.quit (); - false - in - - ignore (window#connect#destroy ~callback:GMain.quit); - ignore (window#event#connect#delete ~callback:quit); - ignore (quit_item#connect#activate - ~callback:(fun () -> ignore (quit ()); ())); - - window#add_accel_group accel_group; - - (* Display the window. *) - window#show () diff --git a/mlvirtmanager/mlvirtmanager_mainwindow.mli b/mlvirtmanager/mlvirtmanager_mainwindow.mli deleted file mode 100755 index 22fce47..0000000 --- a/mlvirtmanager/mlvirtmanager_mainwindow.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* virt-manager-like graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program 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 General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - Make the main window. -*) - -(** This function creates the main window. You have to pass in - callback functions to wire everything up. -*) -val make : open_connection:(unit -> unit) -> - start_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) -> - pause_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) -> - resume_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) -> - shutdown_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) -> unit -- cgit