+++ /dev/null
-(* 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 Virt_ctrl_gettext.Gettext
-
-type name = string
-type uri = string
-type service = name * uri
-
-let local_xen_uri = "xen:///"
-let local_qemu_uri = "qemu:///system"
-
-(* Code in Vc_dbus overrides this, if that capability was compiled in. *)
-let find_libvirtd_with_zeroconf = ref (fun () -> [])
-
-(* Code in Vc_icons may override these with icons. *)
-let icon_16x16_devices_computer_png = ref None
-let icon_24x24_devices_computer_png = ref None
-let icon_32x32_devices_computer_png = ref None
-let icon_48x48_devices_computer_png = ref None
-
-(* Open connection dialog. *)
-let open_connection parent () =
- let title = s_ "Open connection to hypervisor" in
- let position = `CENTER_ON_PARENT in
-
- let dlg = GWindow.dialog ~title ~position ~parent
- ~modal:true ~width:450 () in
-
- (* We will enter the Gtk main loop recursively. Wire up close and
- * other buttons to quit the recursive main loop.
- *)
- ignore (dlg#connect#destroy ~callback:GMain.quit);
- ignore (dlg#event#connect#delete
- ~callback:(fun _ -> GMain.quit (); false));
-
- let uri = ref None in
-
- (* Pack the buttons into the dialog. *)
- let vbox = dlg#vbox in
- vbox#set_spacing 5;
-
- (* Local connections. *)
- let () =
- let frame =
- GBin.frame ~label:(s_ "This machine") ~packing:vbox#pack () in
- let hbox = GPack.hbox ~packing:frame#add () in
- hbox#set_spacing 20;
- ignore (
- let packing = hbox#pack in
- match !icon_24x24_devices_computer_png with
- | None -> GMisc.image ~stock:`DIRECTORY ~packing ()
- | Some pixbuf -> GMisc.image ~pixbuf ~packing ()
- );
-
- let vbox = GPack.vbox ~packing:hbox#pack () in
- vbox#set_spacing 5;
-
- let xen_button =
- GButton.button ~label:(s_ "Xen hypervisor")
- ~packing:vbox#pack () in
- ignore (xen_button#connect#clicked
- ~callback:(fun () ->
- uri := Some local_xen_uri;
- dlg#destroy ()));
- let qemu_button =
- GButton.button ~label:(s_ "QEMU or KVM")
- ~packing:vbox#pack () in
- ignore (qemu_button#connect#clicked
- ~callback:(fun () ->
- uri := Some local_qemu_uri;
- dlg#destroy ())) in
-
- (* Network connections. *)
- let () =
- let frame =
- GBin.frame ~label:(s_ "Local network")
- ~packing:(vbox#pack ~expand:true) () in
- let hbox = GPack.hbox ~packing:frame#add () in
- hbox#set_spacing 20;
- ignore (GMisc.image ~stock:`NETWORK ~packing:hbox#pack ());
-
- let vbox = GPack.vbox ~packing:(hbox#pack ~expand:true) () in
- vbox#set_spacing 5;
-
- let cols = new GTree.column_list in
- (*let col_icon = cols#add Gobject.Data.string in*)
- let col_name = cols#add Gobject.Data.string in
- let model = GTree.list_store cols in
-
- let icons = GTree.icon_view
- ~selection_mode:`SINGLE ~model
- ~height:200
- ~packing:(vbox#pack ~expand:true ~fill:true) () in
- icons#set_border_width 4;
-
- (*icons#set_pixbuf_column col_icon;*)
- icons#set_text_column col_name;
-
- let refresh () =
- model#clear ();
- let services = !find_libvirtd_with_zeroconf () in
-
- (*let pixbuf = !icon_16x16_devices_computer_png in*)
- List.iter (
- fun (name, _) ->
- let row = model#append () in
- model#set ~row ~column:col_name name;
- (*match pixbuf with
- | None -> ()
- | Some pixbuf -> model#set ~row ~column:col_icon pixbuf*)
- ) services
- in
- refresh ();
-
- let hbox = GPack.hbox ~packing:vbox#pack () in
- let refresh_button =
- GButton.button ~label:(s_ "Refresh")
- ~stock:`REFRESH ~packing:hbox#pack () in
- let open_button =
- GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in
-
- ignore (refresh_button#connect#clicked ~callback:refresh);
-
- (* Function callback when someone selects and hits Open. *)
- let callback () =
- match icons#get_selected_items with
- | [] -> () (* nothing selected *)
- | path :: _ ->
- let row = model#get_iter path in
- let name = model#get ~row ~column:col_name in
- let services = !find_libvirtd_with_zeroconf () in
- try
- uri := Some (List.assoc name services);
- dlg#destroy ()
- with
- Not_found -> () in
-
- ignore (open_button#connect#clicked ~callback) in
-
- (* Custom connections. *)
- let () =
- let frame =
- GBin.frame ~label:(s_ "URI connection") ~packing:vbox#pack () in
- let hbox = GPack.hbox ~packing:frame#add () in
- hbox#set_spacing 20;
- ignore (GMisc.image ~stock:`CONNECT ~packing:hbox#pack ());
-
- let hbox = GPack.hbox ~packing:(hbox#pack ~expand:true) () in
- let entry =
- GEdit.entry ~text:"xen://localhost/"
- ~packing:(hbox#pack ~expand:true ~fill:true) () in
- let button =
- GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in
-
- ignore (button#connect#clicked
- ~callback:(fun () ->
- uri := Some entry#text;
- dlg#destroy ()));
-
- () in
-
-
- (* Just a cancel button in the action area. *)
- let cancel_button =
- GButton.button ~label:(s_ "Cancel")
- ~packing:dlg#action_area#pack () in
- ignore (cancel_button#connect#clicked
- ~callback:(fun () ->
- uri := None;
- dlg#destroy ()));
-
- dlg#show ();
-
- (* Enter Gtk main loop recursively. *)
- GMain.main ();
-
- match !uri with
- | None -> ()
- | Some uri -> Vc_connections.open_connection uri
-
-(* Callback from the Connect button drop-down menu. *)
-let open_local_xen () =
- Vc_connections.open_connection local_xen_uri
-
-let open_local_qemu () =
- Vc_connections.open_connection local_qemu_uri
git.annexia.org / virt-top.git / blobdiff