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.
22 type service = name * uri
24 let local_xen_uri = "xen:///"
25 let local_qemu_uri = "qemu:///system"
27 (* Code in Vc_dbus overrides this, if that capability was compiled in. *)
28 let find_libvirtd_with_zeroconf = ref (fun () -> [])
30 (* Code in Vc_icons may override these with icons. *)
31 let icon_16x16_devices_computer_png = ref None
32 let icon_24x24_devices_computer_png = ref None
33 let icon_32x32_devices_computer_png = ref None
34 let icon_48x48_devices_computer_png = ref None
36 (* Open connection dialog. *)
37 let open_connection parent () =
38 let title = "Open connection to hypervisor" in
39 let position = `CENTER_ON_PARENT in
41 let dlg = GWindow.dialog ~title ~position ~parent
42 ~modal:true ~width:450 () in
44 (* We will enter the Gtk main loop recursively. Wire up close and
45 * other buttons to quit the recursive main loop.
47 ignore (dlg#connect#destroy ~callback:GMain.quit);
48 ignore (dlg#event#connect#delete
49 ~callback:(fun _ -> GMain.quit (); false));
53 (* Pack the buttons into the dialog. *)
54 let vbox = dlg#vbox in
57 (* Local connections. *)
60 GBin.frame ~label:"This machine" ~packing:vbox#pack () in
61 let hbox = GPack.hbox ~packing:frame#add () in
64 let packing = hbox#pack in
65 match !icon_24x24_devices_computer_png with
66 | None -> GMisc.image ~stock:`DIRECTORY ~packing ()
67 | Some pixbuf -> GMisc.image ~pixbuf ~packing ()
70 let vbox = GPack.vbox ~packing:hbox#pack () in
74 GButton.button ~label:"Xen hypervisor"
75 ~packing:vbox#pack () in
76 ignore (xen_button#connect#clicked
78 uri := Some local_xen_uri;
81 GButton.button ~label:"QEMU or KVM"
82 ~packing:vbox#pack () in
83 ignore (qemu_button#connect#clicked
85 uri := Some local_qemu_uri;
88 (* Network connections. *)
91 GBin.frame ~label:"Local network"
92 ~packing:(vbox#pack ~expand:true) () in
93 let hbox = GPack.hbox ~packing:frame#add () in
95 ignore (GMisc.image ~stock:`NETWORK ~packing:hbox#pack ());
97 let vbox = GPack.vbox ~packing:(hbox#pack ~expand:true) () in
100 let cols = new GTree.column_list in
101 (*let col_icon = cols#add Gobject.Data.string in*)
102 let col_name = cols#add Gobject.Data.string in
103 let model = GTree.list_store cols in
105 let icons = GTree.icon_view
106 ~selection_mode:`SINGLE ~model
108 ~packing:(vbox#pack ~expand:true ~fill:true) () in
109 icons#set_border_width 4;
111 (*icons#set_pixbuf_column col_icon;*)
112 icons#set_text_column col_name;
116 let services = !find_libvirtd_with_zeroconf () in
118 (*let pixbuf = !icon_16x16_devices_computer_png in*)
121 let row = model#append () in
122 model#set ~row ~column:col_name name;
125 | Some pixbuf -> model#set ~row ~column:col_icon pixbuf*)
130 let hbox = GPack.hbox ~packing:vbox#pack () in
132 GButton.button ~label:"Refresh" ~stock:`REFRESH ~packing:hbox#pack () in
134 GButton.button ~label:"Open" ~packing:hbox#pack () in
136 ignore (refresh_button#connect#clicked ~callback:refresh);
138 (* Function callback when someone selects and hits Open. *)
140 match icons#get_selected_items with
141 | [] -> () (* nothing selected *)
143 let row = model#get_iter path in
144 let name = model#get ~row ~column:col_name in
145 let services = !find_libvirtd_with_zeroconf () in
147 uri := Some (List.assoc name services);
152 ignore (open_button#connect#clicked ~callback) in
154 (* Custom connections. *)
157 GBin.frame ~label:"URI connection" ~packing:vbox#pack () in
158 let hbox = GPack.hbox ~packing:frame#add () in
160 ignore (GMisc.image ~stock:`CONNECT ~packing:hbox#pack ());
162 let hbox = GPack.hbox ~packing:(hbox#pack ~expand:true) () in
164 GEdit.entry ~text:"xen://localhost/"
165 ~packing:(hbox#pack ~expand:true ~fill:true) () in
167 GButton.button ~label:"Open" ~packing:hbox#pack () in
169 ignore (button#connect#clicked
171 uri := Some entry#text;
177 (* Just a cancel button in the action area. *)
179 GButton.button ~label:"Cancel"
180 ~packing:dlg#action_area#pack () in
181 ignore (cancel_button#connect#clicked
188 (* Enter Gtk main loop recursively. *)
193 | Some uri -> Vc_connections.open_connection uri
195 (* Callback from the Connect button drop-down menu. *)
196 let open_local_xen () =
197 Vc_connections.open_connection local_xen_uri
199 let open_local_qemu () =
200 Vc_connections.open_connection local_qemu_uri