diff options
author | Richard W.M. Jones <rjones@redhat.com> | 2008-02-16 16:28:44 +0000 |
---|---|---|
committer | Richard W.M. Jones <rjones@redhat.com> | 2008-02-16 16:28:44 +0000 |
commit | 5881ddaa61385403718e1e5b415057a2d3ef4c45 (patch) | |
tree | cd40a40accabe8304df64d1216365f7f766082ba /virt-ctrl/vc_mainwindow.ml | |
parent | 8a2211eb0976db33a6795ee9933bd7e7400c933c (diff) | |
download | virt-top-5881ddaa61385403718e1e5b415057a2d3ef4c45.tar.gz virt-top-5881ddaa61385403718e1e5b415057a2d3ef4c45.tar.xz virt-top-5881ddaa61385403718e1e5b415057a2d3ef4c45.zip |
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.
Diffstat (limited to 'virt-ctrl/vc_mainwindow.ml')
-rw-r--r-- | virt-ctrl/vc_mainwindow.ml | 19 |
1 files changed, 16 insertions, 3 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 |