*)
open Printf
+open Virt_ctrl_gettext.Gettext
-let title = "Virtual Control"
+let title = s_ "Virtual Control"
let utf8_copyright = "\194\169"
GToolbox.message_box
~title
~icon
- ("Virtualization control tool (virt-ctrl) by\n" ^
- "Richard W.M. Jones (rjones@redhat.com).\n\n" ^
- "Copyright " ^ utf8_copyright ^ " 2007-2008 Red Hat Inc.\n\n" ^
- "Libvirt version: " ^ virt_version ^ "\n" ^
- "Gtk toolkit version: " ^ gtk_version)
+ (sprintf (f_ "Virtualization control tool (virt-ctrl) by
+Richard W.M. Jones (rjones@redhat.com).
+
+Copyright %s 2007-2008 Red Hat Inc.
+
+Libvirt version: %s
+
+Gtk toolkit version: %s") utf8_copyright virt_version gtk_version)
(* Catch any exception and throw up a dialog. *)
let () =
(* A nicer exception printing function. *)
let string_of_exn = function
| Libvirt.Virterror err ->
- "Virtualisation error: " ^ (Libvirt.Virterror.to_string err)
+ s_ "Virtualisation error" ^ ": " ^ (Libvirt.Virterror.to_string err)
| Failure msg -> msg
| exn -> Printexc.to_string exn
in
fun exn ->
let label = string_of_exn exn in
prerr_endline label;
- let title = "Error" in
+ let title = s_ "Error" in
let icon = GMisc.image () in
icon#set_stock `DIALOG_ERROR;
icon#set_icon_size `DIALOG;
GToolbox.message_box ~title ~icon label
-(* Open connection dialog.
- * This should be a lot more sophisticated. XXX
- *)
-let open_connection () =
- let title = "Open connection to hypervisor" in
- let uri =
- GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in
- match uri with
- | None -> ()
- | Some uri -> Vc_connections.open_connection uri
-
let make
~start_domain ~pause_domain ~resume_domain ~shutdown_domain
~open_domain_details =
let vbox = GPack.vbox ~packing:window#add () in
(* Menu bar. *)
- let menubar = GMenu.menu_bar ~packing:vbox#pack () in
- let factory = new GMenu.factory menubar in
- let accel_group = factory#accel_group in
- let file_menu = factory#add_submenu "File" in
- let help_menu = factory#add_submenu "Help" in
+ let quit_item =
+ let menubar = GMenu.menu_bar ~packing:vbox#pack () in
+ let factory = new GMenu.factory menubar in
+ let accel_group = factory#accel_group in
+ let file_menu = factory#add_submenu (s_ "File") in
+ let help_menu = factory#add_submenu (s_ "Help") in
- (* File menu. *)
- let factory = new GMenu.factory file_menu ~accel_group in
- let open_item = factory#add_item "Open connection ..."
- ~key:GdkKeysyms._O in
- ignore (factory#add_separator ());
- let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in
+ window#add_accel_group accel_group;
- ignore (open_item#connect#activate ~callback:open_connection);
+ (* File menu. *)
+ let factory = new GMenu.factory file_menu ~accel_group in
+ let open_item = factory#add_item (s_ "Open connection ...")
+ ~key:GdkKeysyms._O in
+ ignore (factory#add_separator ());
+ let quit_item = factory#add_item (s_ "Quit") ~key:GdkKeysyms._Q in
- (* Help menu. *)
- let factory = new GMenu.factory help_menu ~accel_group in
- let help_item = factory#add_item "Help" in
- let help_about_item = factory#add_item "About ..." in
+ ignore (open_item#connect#activate
+ ~callback:(Vc_connection_dlg.open_connection window));
- ignore (help_about_item#connect#activate ~callback:help_about);
+ (* Help menu. *)
+ let factory = new GMenu.factory help_menu ~accel_group in
+ let help_item = factory#add_item (s_ "Help") in
+ let help_about_item = factory#add_item (s_ "About ...") in
+
+ ignore (help_about_item#connect#activate ~callback:help_about);
+
+ quit_item in
(* The toolbar. *)
let toolbar = GButton.toolbar ~packing:vbox#pack () in
- 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
- let pause_button =
- GButton.tool_button ~label:"Pause" ~stock:`MEDIA_PAUSE
- ~packing:toolbar#insert () in
- let resume_button =
- GButton.tool_button ~label:"Resume" ~stock:`MEDIA_PLAY
- ~packing:toolbar#insert () in
- let shutdown_button =
- GButton.tool_button ~label:"Shutdown" ~stock:`STOP
- ~packing:toolbar#insert () in
(* 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: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
- ~callback:(pause_domain tree model columns));
- ignore (resume_button#connect#clicked
- ~callback:(resume_domain tree model columns));
- ignore (shutdown_button#connect#clicked
- ~callback:(shutdown_domain tree model columns));
+ (* Add buttons to the toolbar (requires the treeview to
+ * have been made above).
+ *)
+ let () =
+ let connect_button_menu = GMenu.menu () in
+ let connect_button =
+ GButton.menu_tool_button
+ ~label:(s_ "Connect ...") ~stock:`CONNECT
+ ~menu:connect_button_menu
+ ~packing:toolbar#insert () in
+ ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
+ let open_button =
+ GButton.tool_button ~label:(s_ "Details") ~stock:`OPEN
+ ~packing:toolbar#insert () in
+ ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
+ let start_button =
+ GButton.tool_button ~label:(s_ "Start") ~stock:`ADD
+ ~packing:toolbar#insert () in
+ let pause_button =
+ GButton.tool_button ~label:(s_ "Pause") ~stock:`MEDIA_PAUSE
+ ~packing:toolbar#insert () in
+ let resume_button =
+ GButton.tool_button ~label:(s_ "Resume") ~stock:`MEDIA_PLAY
+ ~packing:toolbar#insert () in
+ ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
+ let shutdown_button =
+ GButton.tool_button ~label:(s_ "Shutdown") ~stock:`STOP
+ ~packing:toolbar#insert () in
+
+ (* Set callbacks for the toolbar buttons. *)
+ ignore (connect_button#connect#clicked
+ ~callback:(Vc_connection_dlg.open_connection window));
+ 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
+ ~callback:(pause_domain tree model columns));
+ ignore (resume_button#connect#clicked
+ ~callback:(resume_domain tree model columns));
+ ignore (shutdown_button#connect#clicked
+ ~callback:(shutdown_domain tree model columns));
+
+ (* Set a menu on the connect menu-button. *)
+ let () =
+ let factory = new GMenu.factory connect_button_menu (*~accel_group*) in
+ let local_xen = factory#add_item (s_ "Local Xen") in
+ let local_qemu = factory#add_item (s_ "Local QEMU/KVM") in
+ ignore (factory#add_separator ());
+ let open_dialog = factory#add_item (s_ "Connect to ...") in
+ ignore (local_xen#connect#activate
+ ~callback:Vc_connection_dlg.open_local_xen);
+ ignore (local_qemu#connect#activate
+ ~callback:Vc_connection_dlg.open_local_qemu);
+ ignore (open_dialog#connect#activate
+ ~callback:(Vc_connection_dlg.open_connection window)) in
+ () in
(* Make a timeout function which is called once per second. *)
let state = ref initial_state in
(* Quit. *)
let quit _ =
GMain.Timeout.remove timeout_id;
- GMain.Main.quit ();
+ GMain.quit ();
false
in
ignore (quit_item#connect#activate
~callback:(fun () -> ignore (quit ()); ()));
- window#add_accel_group accel_group;
-
(* Display the window. *)
window#show ()
git.annexia.org / virt-top.git / blobdiff