-(* virt-manager-like graphical management tool.
+(* virt-ctrl: A graphical management tool.
(C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
http://libvirt.org/
GToolbox.message_box
~title
~icon
- ("Virtual control (virt-ctrl) by\n" ^
+ ("Virtualization control tool (virt-ctrl) by\n" ^
"Richard W.M. Jones (rjones@redhat.com).\n\n" ^
- "Copyright " ^ utf8_copyright ^ " 2007 Red Hat Inc.\n\n" ^
+ "Copyright " ^ utf8_copyright ^ " 2007-2008 Red Hat Inc.\n\n" ^
"Libvirt version: " ^ virt_version ^ "\n" ^
"Gtk toolkit version: " ^ gtk_version)
GtkSignal.user_handler :=
fun exn ->
let label = string_of_exn exn in
+ prerr_endline label;
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 =
+let make
+ ~start_domain ~pause_domain ~resume_domain ~shutdown_domain
+ ~open_domain_details =
(* Create the main window. *)
let window = GWindow.window ~width:800 ~height:600 ~title () in
let vbox = GPack.vbox ~packing:window#add () in
ignore (factory#add_separator ());
let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in
- ignore (open_item#connect#activate ~callback:open_connection);
+ ignore (open_item#connect#activate
+ ~callback:Vc_connection_dlg.open_connection);
(* Help menu. *)
let factory = new GMenu.factory help_menu ~accel_group in
let connect_button =
GButton.tool_button ~label:"Connect ..." ~stock:`CONNECT
~packing:toolbar#insert () in
+ ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
+ let open_button =
+ GButton.tool_button ~label:"Details" ~stock:`OPEN
+ ~packing:toolbar#insert () in
+ ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
let start_button =
GButton.tool_button ~label:"Start" ~stock:`ADD
~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) =
Vc_connections.make_treeview
~packing:(vbox#pack ~expand:true ~fill:true) () in
+ (* Set callbacks for the buttons. *)
+ ignore (connect_button#connect#clicked
+ ~callback:Vc_connection_dlg.open_connection);
+ ignore (open_button#connect#clicked
+ ~callback:(open_domain_details tree model columns));
ignore (start_button#connect#clicked
~callback:(start_domain tree model columns));
ignore (pause_button#connect#clicked
(* Make a timeout function which is called once per second. *)
let state = ref initial_state in
let callback () =
- state := Vc_connections.repopulate tree model columns !state;
+ (* Gc.compact is generally not safe in lablgtk programs, but
+ * is explicitly allowed in timeouts (see lablgtk README).
+ * This ensures memory is compacted regularly, but is also an
+ * excellent way to catch memory bugs in the ocaml libvirt bindings.
+ *)
+ Gc.compact ();
+
+ (* Ugh: Bug in lablgtk causes a segfault if a timeout raises an
+ * exception. Catch and print exceptions instead.
+ *)
+ (try state := Vc_connections.repopulate tree model columns !state
+ with exn -> prerr_endline (Printexc.to_string exn));
+
true
in
let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in