1 (* virt-ctrl: A graphical management tool.
2 (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
21 open Virt_ctrl_gettext.Gettext
23 let title = s_ "Virtual Control"
25 let utf8_copyright = "\194\169"
29 let gtk_major, gtk_minor, gtk_micro = GMain.Main.version in
30 sprintf "%d.%d.%d" gtk_major gtk_minor gtk_micro in
31 let virt_version = string_of_int (fst (Libvirt.get_version ())) in
32 let title = "About " ^ title in
33 let icon = GMisc.image () in
34 icon#set_stock `DIALOG_INFO;
35 icon#set_icon_size `DIALOG;
39 (sprintf (f_ "Virtualization control tool (virt-ctrl) by
40 Richard W.M. Jones (rjones@redhat.com).
42 Copyright %s 2007-2008 Red Hat Inc.
46 Gtk toolkit version: %s") utf8_copyright virt_version gtk_version)
48 (* Set up a global exception handler to catch any exception and throw
52 (* A nicer exception printing function. *)
53 let string_of_exn = function
54 | Libvirt.Virterror err ->
55 s_ "Virtualisation error" ^ ": " ^ (Libvirt.Virterror.to_string err)
57 | exn -> Printexc.to_string exn
59 GtkSignal.user_handler :=
61 let label = string_of_exn exn in
63 let title = s_ "Error" in
64 let icon = GMisc.image () in
65 icon#set_stock `DIALOG_ERROR;
66 icon#set_icon_size `DIALOG;
67 GToolbox.message_box ~title ~icon label
70 ~start_domain ~pause_domain ~resume_domain ~shutdown_domain
71 ~open_domain_details =
72 (* Create the main window. *)
73 let window = GWindow.window ~width:800 ~height:600 ~title () in
74 let vbox = GPack.vbox ~packing:window#add () in
77 let quit_item, install_item =
78 let menubar = GMenu.menu_bar ~packing:vbox#pack () in
79 let factory = new GMenu.factory menubar in
80 let accel_group = factory#accel_group in
81 let file_menu = factory#add_submenu (s_ "File") in
82 let help_menu = factory#add_submenu (s_ "Help") in
84 window#add_accel_group accel_group;
87 let factory = new GMenu.factory file_menu ~accel_group in
88 let open_item = factory#add_item (s_ "Open connection ...")
90 ignore (factory#add_separator ());
91 let install_item = factory#add_item (s_ "Install new guest ...")
93 ignore (factory#add_separator ());
94 let quit_item = factory#add_item (s_ "Quit") ~key:GdkKeysyms._Q in
96 ignore (open_item#connect#activate
97 ~callback:(Vc_connection_dlg.open_connection window));
99 let factory = new GMenu.factory help_menu ~accel_group in
100 let help_item = factory#add_item (s_ "Help") in
101 let help_about_item = factory#add_item (s_ "About ...") in
103 ignore (help_about_item#connect#activate ~callback:help_about);
105 quit_item, install_item in
108 let toolbar = GButton.toolbar ~packing:vbox#pack () in
111 let (tree, model, columns, initial_state) =
112 Vc_connections.make_treeview
113 ~packing:(vbox#pack ~expand:true ~fill:true) () in
115 (* Wire up the install item (requires the treeview for selection). *)
116 ignore (install_item#connect#activate
119 let conn_id = get_conn_id tree model columns in
121 | None -> () (* nothing selected *)
122 | Some conn_id -> (* connection ID selected *)
123 Vc_install_dlg.install_guest window conn_id ()
127 (* Add buttons to the toolbar (requires the treeview to
128 * have been made above).
131 let connect_button_menu = GMenu.menu () in
133 GButton.menu_tool_button
134 ~label:(s_ "Connect ...") ~stock:`CONNECT
135 ~menu:connect_button_menu
136 ~packing:toolbar#insert () in
137 ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
139 GButton.tool_button ~label:(s_ "Details") ~stock:`OPEN
140 ~packing:toolbar#insert () in
141 ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
143 GButton.tool_button ~label:(s_ "Start") ~stock:`ADD
144 ~packing:toolbar#insert () in
146 GButton.tool_button ~label:(s_ "Pause") ~stock:`MEDIA_PAUSE
147 ~packing:toolbar#insert () in
149 GButton.tool_button ~label:(s_ "Resume") ~stock:`MEDIA_PLAY
150 ~packing:toolbar#insert () in
151 ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
152 let shutdown_button =
153 GButton.tool_button ~label:(s_ "Shutdown") ~stock:`STOP
154 ~packing:toolbar#insert () in
156 (* Set callbacks for the toolbar buttons. *)
157 ignore (connect_button#connect#clicked
158 ~callback:(Vc_connection_dlg.open_connection window));
159 ignore (open_button#connect#clicked
160 ~callback:(open_domain_details tree model columns));
161 ignore (start_button#connect#clicked
162 ~callback:(start_domain tree model columns));
163 ignore (pause_button#connect#clicked
164 ~callback:(pause_domain tree model columns));
165 ignore (resume_button#connect#clicked
166 ~callback:(resume_domain tree model columns));
167 ignore (shutdown_button#connect#clicked
168 ~callback:(shutdown_domain tree model columns));
170 (* Set a menu on the connect menu-button. *)
172 let factory = new GMenu.factory connect_button_menu (*~accel_group*) in
173 let local_xen = factory#add_item (s_ "Local Xen") in
174 let local_qemu = factory#add_item (s_ "Local QEMU/KVM") in
175 ignore (factory#add_separator ());
176 let open_dialog = factory#add_item (s_ "Connect to ...") in
177 ignore (local_xen#connect#activate
178 ~callback:Vc_connection_dlg.open_local_xen);
179 ignore (local_qemu#connect#activate
180 ~callback:Vc_connection_dlg.open_local_qemu);
181 ignore (open_dialog#connect#activate
182 ~callback:(Vc_connection_dlg.open_connection window)) in
185 (* Make a timeout function which is called once per second. *)
186 let state = ref initial_state in
188 (* Gc.compact is generally not safe in lablgtk programs, but
189 * is explicitly allowed in timeouts (see lablgtk README).
190 * This ensures memory is compacted regularly, but is also an
191 * excellent way to catch memory bugs in the ocaml libvirt bindings.
195 (* Ugh: Bug in lablgtk causes a segfault if a timeout raises an
196 * exception. Catch and print exceptions instead.
198 (try state := Vc_connections.repopulate tree model columns !state
199 with exn -> prerr_endline (Printexc.to_string exn));
203 let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in
207 GMain.Timeout.remove timeout_id;
212 ignore (window#connect#destroy ~callback:GMain.quit);
213 ignore (window#event#connect#delete ~callback:quit);
214 ignore (quit_item#connect#activate
215 ~callback:(fun () -> ignore (quit ()); ()));
217 (* Display the window. *)
220 (* Get the selected connection ID if there is one or return None. *)
221 and get_conn_id (tree : GTree.view) (model : GTree.tree_store)
222 (columns : Vc_connections.columns) =
223 let path, _ = tree#get_cursor () in
225 | None -> None (* No row at all selected. *)
227 let row = model#get_iter path in
228 let (_, _, _, _, _, col_id) = columns in
229 (* Visit parent to get the connid.
230 * If this returns None, then this is already a top-level row
231 * (ie. a connection).
233 match model#iter_parent row with
235 let connid = model#get ~row ~column:col_id in
239 let connid = model#get ~row:parent ~column:col_id in
242 (* Domain or connection disappeared under us. *)
247 | Libvirt.Virterror err ->
248 prerr_endline (Libvirt.Virterror.to_string err);