1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
(* virt-ctrl: A graphical management tool.
(C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
http://libvirt.org/
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)
open Printf
let title = "Virtual Control"
let utf8_copyright = "\194\169"
let help_about () =
let gtk_version =
let gtk_major, gtk_minor, gtk_micro = GMain.Main.version in
sprintf "%d.%d.%d" gtk_major gtk_minor gtk_micro in
let virt_version = string_of_int (fst (Libvirt.get_version ())) in
let title = "About " ^ title in
let icon = GMisc.image () in
icon#set_stock `DIALOG_INFO;
icon#set_icon_size `DIALOG;
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)
(* 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)
| Failure msg -> msg
| exn -> Printexc.to_string exn
in
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;
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 =
(* Create the main window. *)
let window = GWindow.window ~width:800 ~height:600 ~title () in
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
(* 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
ignore (open_item#connect#activate ~callback:open_connection);
(* 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 (help_about_item#connect#activate ~callback:help_about);
(* 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));
(* Make a timeout function which is called once per second. *)
let state = ref initial_state in
let callback () =
(* 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
(* Quit. *)
let quit _ =
GMain.Timeout.remove timeout_id;
GMain.Main.quit ();
false
in
ignore (window#connect#destroy ~callback:GMain.quit);
ignore (window#event#connect#delete ~callback:quit);
ignore (quit_item#connect#activate
~callback:(fun () -> ignore (quit ()); ()));
window#add_accel_group accel_group;
(* Display the window. *)
window#show ()
|
