diff options
| -rw-r--r-- | virt-ctrl/vc_mainwindow.ml | 19 | ||||
| -rw-r--r-- | virt-ctrl/virt_ctrl.ml | 5 |
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 () |