1 (* virt-manager-like graphical management tool.
2 (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
8 let title = "Virtual Machine Manager"
10 let utf8_copyright = "\194\169"
14 let gtk_major, gtk_minor, gtk_micro = GMain.Main.version in
15 sprintf "%d.%d.%d" gtk_major gtk_minor gtk_micro in
16 let virt_version = string_of_int (fst (Libvirt.get_version ())) in
17 let title = "About " ^ title in
18 let icon = GMisc.image () in
19 icon#set_stock `DIALOG_INFO;
20 icon#set_icon_size `DIALOG;
24 ("Virtual machine manager (OCaml version) by\n" ^
25 "Richard W.M. Jones (rjones@redhat.com).\n\n" ^
26 "Copyright " ^ utf8_copyright ^ " 2007 Red Hat Inc.\n\n" ^
27 "Libvirt version: " ^ virt_version ^ "\n" ^
28 "Gtk toolkit version: " ^ gtk_version)
30 (* Catch any exception and throw up a dialog. *)
32 (* A nicer exception printing function. *)
33 let string_of_exn = function
34 | Libvirt.Virterror err ->
35 "Virtualisation error: " ^ (Libvirt.Virterror.to_string err)
37 | exn -> Printexc.to_string exn
39 GtkSignal.user_handler :=
41 let label = string_of_exn exn in
42 let title = "Error" in
43 let icon = GMisc.image () in
44 icon#set_stock `DIALOG_ERROR;
45 icon#set_icon_size `DIALOG;
46 GToolbox.message_box ~title ~icon label
48 let make ~open_connection
49 ~start_domain ~pause_domain ~resume_domain ~shutdown_domain =
50 (* Create the main window. *)
51 let window = GWindow.window ~width:800 ~height:600 ~title () in
52 let vbox = GPack.vbox ~packing:window#add () in
55 let menubar = GMenu.menu_bar ~packing:vbox#pack () in
56 let factory = new GMenu.factory menubar in
57 let accel_group = factory#accel_group in
58 let file_menu = factory#add_submenu "File" in
59 let help_menu = factory#add_submenu "Help" in
62 let factory = new GMenu.factory file_menu ~accel_group in
63 let open_item = factory#add_item "Open connection ..."
65 ignore (factory#add_separator ());
66 let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in
68 ignore (open_item#connect#activate ~callback:open_connection);
71 let factory = new GMenu.factory help_menu ~accel_group in
72 let help_item = factory#add_item "Help" in
73 let help_about_item = factory#add_item "About ..." in
75 ignore (help_about_item#connect#activate ~callback:help_about);
78 let toolbar = GButton.toolbar ~packing:vbox#pack () in
80 GButton.tool_button ~label:"Connect ..." ~stock:`CONNECT
81 ~packing:toolbar#insert () in
83 GButton.tool_button ~label:"Start" ~stock:`ADD
84 ~packing:toolbar#insert () in
86 GButton.tool_button ~label:"Pause" ~stock:`MEDIA_PAUSE
87 ~packing:toolbar#insert () in
89 GButton.tool_button ~label:"Resume" ~stock:`MEDIA_PLAY
90 ~packing:toolbar#insert () in
92 GButton.tool_button ~label:"Shutdown" ~stock:`STOP
93 ~packing:toolbar#insert () in
94 ignore (connect_button#connect#clicked ~callback:open_connection);
97 let (tree, model, columns, initial_state) =
98 Mlvirtmanager_connections.make_treeview
99 ~packing:(vbox#pack ~expand:true ~fill:true) () in
101 ignore (start_button#connect#clicked
102 ~callback:(start_domain tree model columns));
103 ignore (pause_button#connect#clicked
104 ~callback:(pause_domain tree model columns));
105 ignore (resume_button#connect#clicked
106 ~callback:(resume_domain tree model columns));
107 ignore (shutdown_button#connect#clicked
108 ~callback:(shutdown_domain tree model columns));
110 (* Make a timeout function which is called once per second. *)
111 let state = ref initial_state in
113 state := Mlvirtmanager_connections.repopulate tree model columns !state;
116 let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in
120 GMain.Timeout.remove timeout_id;
125 ignore (window#connect#destroy ~callback:GMain.quit);
126 ignore (window#event#connect#delete ~callback:quit);
127 ignore (quit_item#connect#activate
128 ~callback:(fun () -> ignore (quit ()); ()));
130 window#add_accel_group accel_group;
132 (* Display the window. *)