1 (* virt-ctrl: A graphical management tool.
2 (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20 open Virt_ctrl_gettext.Gettext
24 type service = name * uri
26 let local_xen_uri = "xen:///"
27 let local_qemu_uri = "qemu:///system"
29 (* Code in Vc_dbus overrides this, if that capability was compiled in. *)
30 let find_libvirtd_with_zeroconf = ref (fun () -> [])
32 (* Code in Vc_icons may override these with icons. *)
33 let icon_16x16_devices_computer_png = ref None
34 let icon_24x24_devices_computer_png = ref None
35 let icon_32x32_devices_computer_png = ref None
36 let icon_48x48_devices_computer_png = ref None
38 (* Open connection dialog. *)
39 let open_connection parent () =
40 let title = s_ "Open connection to hypervisor" in
41 let position = `CENTER_ON_PARENT in
43 let dlg = GWindow.dialog ~title ~position ~parent
44 ~modal:true ~width:450 () in
46 (* We will enter the Gtk main loop recursively. Wire up close and
47 * other buttons to quit the recursive main loop.
49 ignore (dlg#connect#destroy ~callback:GMain.quit);
50 ignore (dlg#event#connect#delete
51 ~callback:(fun _ -> GMain.quit (); false));
55 (* Pack the buttons into the dialog. *)
56 let vbox = dlg#vbox in
59 (* Local connections. *)
62 GBin.frame ~label:(s_ "This machine") ~packing:vbox#pack () in
63 let hbox = GPack.hbox ~packing:frame#add () in
66 let packing = hbox#pack in
67 match !icon_24x24_devices_computer_png with
68 | None -> GMisc.image ~stock:`DIRECTORY ~packing ()
69 | Some pixbuf -> GMisc.image ~pixbuf ~packing ()
72 let vbox = GPack.vbox ~packing:hbox#pack () in
76 GButton.button ~label:(s_ "Xen hypervisor")
77 ~packing:vbox#pack () in
78 ignore (xen_button#connect#clicked
80 uri := Some local_xen_uri;
83 GButton.button ~label:(s_ "QEMU or KVM")
84 ~packing:vbox#pack () in
85 ignore (qemu_button#connect#clicked
87 uri := Some local_qemu_uri;
90 (* Network connections. *)
93 GBin.frame ~label:(s_ "Local network")
94 ~packing:(vbox#pack ~expand:true) () in
95 let hbox = GPack.hbox ~packing:frame#add () in
97 ignore (GMisc.image ~stock:`NETWORK ~packing:hbox#pack ());
99 let vbox = GPack.vbox ~packing:(hbox#pack ~expand:true) () in
102 let cols = new GTree.column_list in
103 (*let col_icon = cols#add Gobject.Data.string in*)
104 let col_name = cols#add Gobject.Data.string in
105 let model = GTree.list_store cols in
107 let icons = GTree.icon_view
108 ~selection_mode:`SINGLE ~model
110 ~packing:(vbox#pack ~expand:true ~fill:true) () in
111 icons#set_border_width 4;
113 (*icons#set_pixbuf_column col_icon;*)
114 icons#set_text_column col_name;
118 let services = !find_libvirtd_with_zeroconf () in
120 (*let pixbuf = !icon_16x16_devices_computer_png in*)
123 let row = model#append () in
124 model#set ~row ~column:col_name name;
127 | Some pixbuf -> model#set ~row ~column:col_icon pixbuf*)
132 let hbox = GPack.hbox ~packing:vbox#pack () in
134 GButton.button ~label:(s_ "Refresh")
135 ~stock:`REFRESH ~packing:hbox#pack () in
137 GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in
139 ignore (refresh_button#connect#clicked ~callback:refresh);
141 (* Function callback when someone selects and hits Open. *)
143 match icons#get_selected_items with
144 | [] -> () (* nothing selected *)
146 let row = model#get_iter path in
147 let name = model#get ~row ~column:col_name in
148 let services = !find_libvirtd_with_zeroconf () in
150 uri := Some (List.assoc name services);
155 ignore (open_button#connect#clicked ~callback) in
157 (* Custom connections. *)
160 GBin.frame ~label:(s_ "URI connection") ~packing:vbox#pack () in
161 let hbox = GPack.hbox ~packing:frame#add () in
163 ignore (GMisc.image ~stock:`CONNECT ~packing:hbox#pack ());
165 let hbox = GPack.hbox ~packing:(hbox#pack ~expand:true) () in
167 GEdit.entry ~text:"xen://localhost/"
168 ~packing:(hbox#pack ~expand:true ~fill:true) () in
170 GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in
172 ignore (button#connect#clicked
174 uri := Some entry#text;
180 (* Just a cancel button in the action area. *)
182 GButton.button ~label:(s_ "Cancel")
183 ~packing:dlg#action_area#pack () in
184 ignore (cancel_button#connect#clicked
191 (* Enter Gtk main loop recursively. *)
196 | Some uri -> Vc_connections.open_connection uri
198 (* Callback from the Connect button drop-down menu. *)
199 let open_local_xen () =
200 Vc_connections.open_connection local_xen_uri
202 let open_local_qemu () =
203 Vc_connections.open_connection local_qemu_uri