From: Richard W.M. Jones <rjones@redhat.com> <"Richard W.M. Jones <rjones@redhat.com>">
Date: Sat, 16 Feb 2008 16:28:44 +0000 (+0000)
Subject: Clean up memory handling.
X-Git-Tag: 1.0.4~42
X-Git-Url: http://git.annexia.org/?p=virt-top.git;a=commitdiff_plain;h=5881ddaa61385403718e1e5b415057a2d3ef4c45

Clean up memory handling.
 - Call Gc.compact during timeout handler and when program exits to check
   for memory errors.
 - Don't allow timeout exceptions to propagate - causes a segfault in lablgtk.
 - Tidy up the About dialog.
---

diff --git a/virt-ctrl/vc_mainwindow.ml b/virt-ctrl/vc_mainwindow.ml
index cf957c3..4fd82c9 100644
--- a/virt-ctrl/vc_mainwindow.ml
+++ b/virt-ctrl/vc_mainwindow.ml
@@ -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,6 +53,7 @@ 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;
@@ -124,7 +125,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
diff --git a/virt-ctrl/virt_ctrl.ml b/virt-ctrl/virt_ctrl.ml
index 1de68f4..b4a3159 100644
--- a/virt-ctrl/virt_ctrl.ml
+++ b/virt-ctrl/virt_ctrl.ml
@@ -29,4 +29,7 @@ let () =
     ~shutdown_domain:Vc_domain_ops.shutdown_domain;
 
   (* Enter the Gtk main loop. *)
-  GMain.main ()
+  GMain.main ();
+
+  (* Useful to catch memory bugs in the ocaml libvirt bindings. *)
+  Gc.compact ()