Updated deps.

[virt-top.git] / virt-ctrl / vc_mainwindow.ml

diff --git a/virt-ctrl/vc_mainwindow.ml b/virt-ctrl/vc_mainwindow.ml
index e8dc4af..f859d10 100644 (file)
--- a/virt-ctrl/vc_mainwindow.ml
+++ b/virt-ctrl/vc_mainwindow.ml
@@ -1,4 +1,4 @@
-(* 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/
 
@@ -35,9 +35,9 @@ let help_about () =
   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)
 
@@ -53,14 +53,16 @@ let () =
   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
@@ -79,7 +81,8 @@ let make ~open_connection
   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
@@ -93,6 +96,11 @@ let make ~open_connection
   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
@@ -105,13 +113,17 @@ let make ~open_connection
   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
@@ -124,7 +136,19 @@ let make ~open_connection
   (* 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