summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorRichard W.M. Jones <rjones@redhat.com>2008-02-16 16:28:44 +0000
committerRichard W.M. Jones <rjones@redhat.com>2008-02-16 16:28:44 +0000
commit5881ddaa61385403718e1e5b415057a2d3ef4c45 (patch)
treecd40a40accabe8304df64d1216365f7f766082ba
parent8a2211eb0976db33a6795ee9933bd7e7400c933c (diff)
downloadvirt-top-5881ddaa61385403718e1e5b415057a2d3ef4c45.zip
virt-top-5881ddaa61385403718e1e5b415057a2d3ef4c45.tar.gz
virt-top-5881ddaa61385403718e1e5b415057a2d3ef4c45.tar.xz
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.
-rw-r--r--virt-ctrl/vc_mainwindow.ml19
-rw-r--r--virt-ctrl/virt_ctrl.ml5
2 files changed, 20 insertions, 4 deletions
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 ()