From 02f1c03c9f81e25353aae4900ce19e194b507f71 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 13:51:14 +0100 Subject: Removed virt-ctrl, virt-df, ocaml-libvirt - now in separate repositories. --- virt-ctrl/Makefile.in | 136 ------------ virt-ctrl/mingw-gcc-wrapper.ml | 70 ------ virt-ctrl/rebuild-icons.sh | 44 ---- virt-ctrl/vc_connection_dlg.ml | 203 ----------------- virt-ctrl/vc_connection_dlg.mli | 43 ---- virt-ctrl/vc_connections.ml | 477 ---------------------------------------- virt-ctrl/vc_connections.mli | 102 --------- virt-ctrl/vc_dbus.ml | 317 -------------------------- virt-ctrl/vc_dbus.mli | 22 -- virt-ctrl/vc_domain_ops.ml | 109 --------- virt-ctrl/vc_domain_ops.mli | 35 --- virt-ctrl/vc_helpers.ml | 97 -------- virt-ctrl/vc_helpers.mli | 51 ----- virt-ctrl/vc_icons.ml | 270 ----------------------- virt-ctrl/vc_mainwindow.ml | 202 ----------------- virt-ctrl/vc_mainwindow.mli | 31 --- virt-ctrl/virt_ctrl.ml | 36 --- 17 files changed, 2245 deletions(-) delete mode 100644 virt-ctrl/Makefile.in delete mode 100755 virt-ctrl/mingw-gcc-wrapper.ml delete mode 100755 virt-ctrl/rebuild-icons.sh delete mode 100644 virt-ctrl/vc_connection_dlg.ml delete mode 100644 virt-ctrl/vc_connection_dlg.mli delete mode 100644 virt-ctrl/vc_connections.ml delete mode 100644 virt-ctrl/vc_connections.mli delete mode 100644 virt-ctrl/vc_dbus.ml delete mode 100644 virt-ctrl/vc_dbus.mli delete mode 100644 virt-ctrl/vc_domain_ops.ml delete mode 100644 virt-ctrl/vc_domain_ops.mli delete mode 100644 virt-ctrl/vc_helpers.ml delete mode 100644 virt-ctrl/vc_helpers.mli delete mode 100644 virt-ctrl/vc_icons.ml delete mode 100644 virt-ctrl/vc_mainwindow.ml delete mode 100644 virt-ctrl/vc_mainwindow.mli delete mode 100644 virt-ctrl/virt_ctrl.ml (limited to 'virt-ctrl') diff --git a/virt-ctrl/Makefile.in b/virt-ctrl/Makefile.in deleted file mode 100644 index 7e7c5c4..0000000 --- a/virt-ctrl/Makefile.in +++ /dev/null @@ -1,136 +0,0 @@ -# virt-ctrl (originally called mlvirtmanager) -# Copyright (C) 2007 Red Hat Inc., Richard W.M. Jones -# -# 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. - -INSTALL := @INSTALL@ - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -bindir = @bindir@ - -with_icons = @with_icons@ -icons = @icons@ - -HAVE_GDK_PIXBUF_MLSOURCE = @HAVE_GDK_PIXBUF_MLSOURCE@ - -pkg_dbus = @pkg_dbus@ -pkg_gettext = @pkg_gettext@ - -OCAMLFIND = @OCAMLFIND@ - -OBJS := \ - virt_ctrl_gettext.cmo \ - vc_helpers.cmo \ - vc_connections.cmo \ - vc_domain_ops.cmo \ - vc_connection_dlg.cmo \ - vc_mainwindow.cmo - -ifneq ($(OCAMLFIND),) -# Good, we have ocamlfind. -OCAMLCPACKAGES := -I ../libvirt -package unix,lablgtk2 -ifeq ($(pkg_dbus),yes) -OCAMLCPACKAGES += -package dbus -OBJS += vc_dbus.cmo -endif -ifeq ($(pkg_gettext),yes) -OCAMLCPACKAGES += -package gettext-stub -endif -OCAMLCFLAGS := -g -OCAMLCLIBS := -linkpkg -OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) -OCAMLOPTFLAGS := -OCAMLOPTLIBS := $(OCAMLCLIBS) -else -# Bad boy, please install ocamlfind. -OCAMLCINCS := -I ../libvirt -I @pkg_lablgtk2@ -OCAMLCFLAGS := -g -OCAMLCLIBS := unix.cma lablgtk.cma -OCAMLOPTINCS := $(OCAMLCINCS) -OCAMLOPTFLAGS := -OCAMLOPTLIBS := unix.cmxa lablgtk.cmxa -endif - -ifneq ($(with_icons),no) -OBJS += vc_icons.cmo -endif - -export LIBRARY_PATH=../libvirt -export LD_LIBRARY_PATH=../libvirt - -BYTE_TARGETS := virt-ctrl -OPT_TARGETS := virt-ctrl.opt - -OBJS += virt_ctrl.cmo - -XOBJS := $(OBJS:.cmo=.cmx) - -all: $(BYTE_TARGETS) - -opt: $(OPT_TARGETS) - -ifneq ($(OCAMLFIND),) -virt-ctrl: $(OBJS) - $(OCAMLFIND) ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma gtkInit.cmo -o $@ $^ - -virt-ctrl.opt: $(XOBJS) - $(OCAMLFIND) ocamlopt \ - $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $^ -else -virt-ctrl: $(OBJS) - $(OCAMLC) $(OCAMLCINCS) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma gtkInit.cmo -o $@ $^ - -host_os = @host_os@ - -ifneq ($(host_os),mingw32) -virt-ctrl.opt: $(XOBJS) - $(OCAMLOPT) $(OCAMLOPTINCS) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - $(patsubst %,-cclib %,$(LDFLAGS)) \ - ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $^ -else -# On MinGW, use a hacked 'gcc' wrapper which understands the @... -# syntax for extending the command line. -gcc.exe: mingw-gcc-wrapper.ml - $(OCAMLC) unix.cma $< -o $@ - -virt-ctrl.opt: $(XOBJS) gcc.exe - PATH=.:$$PATH \ - $(OCAMLOPT) $(OCAMLOPTINCS) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - $(patsubst %,-cclib %,$(LDFLAGS)) \ - ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $(XOBJS) -endif -endif - -# Rebuild the icons if newer ones available. -ifneq ($(with_icons),no) -ifneq ($(icons),) -ifeq ($(HAVE_GDK_PIXBUF_MLSOURCE),gdk-pixbuf-mlsource) -vc_icons.ml: rebuild-icons.sh - ./rebuild-icons.sh $(icons) > $@ -endif -endif -endif - -install: - if [ -x virt-ctrl.opt ]; then \ - mkdir -p $(DESTDIR)$(bindir); \ - $(INSTALL) -m 0755 virt-ctrl.opt $(DESTDIR)$(bindir)/virt-ctrl; \ - fi - -include ../Make.rules diff --git a/virt-ctrl/mingw-gcc-wrapper.ml b/virt-ctrl/mingw-gcc-wrapper.ml deleted file mode 100755 index 21cdb8f..0000000 --- a/virt-ctrl/mingw-gcc-wrapper.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* Wrapper around 'gcc'. On MinGW, this wrapper understands the '@...' - * syntax for extending the command line. - *) - -open Printf -open Unix - -let (//) = Filename.concat - -(* Substitute any @... arguments with the file content. *) -let rec input_all_lines chan = - try - let line = input_line chan in - line :: input_all_lines chan - with - End_of_file -> [] - -let argv = Array.map ( - fun arg -> - if arg.[0] = '@' then ( - let chan = open_in (String.sub arg 1 (String.length arg - 1)) in - let lines = input_all_lines chan in - close_in chan; - lines - ) else - [arg] -) Sys.argv - -let argv = Array.to_list argv -let argv = List.flatten argv - -(* Find the real gcc.exe on $PATH, but ignore any '.' elements in the path. - * Note that on Windows, $PATH is split with ';' characters. - *) -let rec split_find str sep f = - try - let i = String.index str sep in - let n = String.length str in - let str, str' = String.sub str 0 i, String.sub str (i+1) (n-i-1) in - match f str with - | None -> split_find str' sep f (* not found, keep searching *) - | Some found -> found - with - Not_found -> - match f str with - | None -> raise Not_found (* not found at all *) - | Some found -> found - -let exists filename = - try access filename [F_OK]; true with Unix_error _ -> false - -let gcc = - split_find (Sys.getenv "PATH") ';' - (function - | "." -> None (* ignore current directory in path *) - | path -> - let gcc = path // "gcc.exe" in - if exists gcc then Some gcc else None) - -(* Finally execute the real gcc with the full argument list. - * Can't use execv here because then the parent process (ocamlopt) thinks - * that this process has finished and deletes all the temp files. Stupid - * Windoze! - *) -let _ = - let argv = List.map Filename.quote (List.tl argv) in - let cmd = String.concat " " (gcc :: argv) in - eprintf "mingw-gcc-wrapper: %s\n%!" cmd; - let r = Sys.command cmd in - exit r diff --git a/virt-ctrl/rebuild-icons.sh b/virt-ctrl/rebuild-icons.sh deleted file mode 100755 index 399e182..0000000 --- a/virt-ctrl/rebuild-icons.sh +++ /dev/null @@ -1,44 +0,0 @@ -#!/bin/sh - -# Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones -# -# 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. - -# Generate vc_icons.ml - -echo <<'EOF' -(* The file vc_icons.ml is automatically generated from rebuild-icons.sh - * Any changes you make will be lost. - *) - -EOF -echo - -# Open any modules which may use icons. -echo "open Vc_connection_dlg" -echo - -while [ $# -gt 0 ]; do - size="$1" - name="$2" - filename="$3" - shift 3 - - gdk-pixbuf-mlsource "$filename" - echo ";;" - - name=`echo -n $name | tr -cs '[0-9a-zA-Z]' '_'` - - echo "icon_${size}x${size}_$name := Some (pixbuf ()) ;;" -done \ No newline at end of file diff --git a/virt-ctrl/vc_connection_dlg.ml b/virt-ctrl/vc_connection_dlg.ml deleted file mode 100644 index f072a1d..0000000 --- a/virt-ctrl/vc_connection_dlg.ml +++ /dev/null @@ -1,203 +0,0 @@ -(* 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 diff --git a/virt-ctrl/vc_connection_dlg.mli b/virt-ctrl/vc_connection_dlg.mli deleted file mode 100644 index 0102713..0000000 --- a/virt-ctrl/vc_connection_dlg.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* 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. - - Make the main window. -*) - -(** The connection dialog. *) -val open_connection : GWindow.window -> unit -> unit - -(** Quick connect to local Xen. *) -val open_local_xen : unit -> unit - -(** Quick connect to local QEMU or KVM. *) -val open_local_qemu : unit -> unit - -type name = string -type uri = string -type service = name * uri - -(** Hook to find libvirtd network services with zeroconf using some - external method, eg. D-Bus or Avahi. *) -val find_libvirtd_with_zeroconf : (unit -> service list) ref - -(** Hooks for icons. *) -val icon_16x16_devices_computer_png : GdkPixbuf.pixbuf option ref -val icon_24x24_devices_computer_png : GdkPixbuf.pixbuf option ref -val icon_32x32_devices_computer_png : GdkPixbuf.pixbuf option ref -val icon_48x48_devices_computer_png : GdkPixbuf.pixbuf option ref diff --git a/virt-ctrl/vc_connections.ml b/virt-ctrl/vc_connections.ml deleted file mode 100644 index 8f5fba0..0000000 --- a/virt-ctrl/vc_connections.ml +++ /dev/null @@ -1,477 +0,0 @@ -(* 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 -open Virt_ctrl_gettext.Gettext - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -open Vc_helpers - -(* List of currently open connections. Actually it's a list of - * (id, Libvirt.Connect.t) so that we can easily identify - * connections by their unique ID. - *) -let get_conns, add_conn, del_conn = - let conns = ref [] in - let id = ref 0 in - let get_conns () = !conns in - let add_conn conn = - incr id; let id = !id in - conns := (id, conn) :: !conns; - id - in - let del_conn id = - conns := List.filter (fun (id', _) -> id <> id') !conns - in - get_conns, add_conn, del_conn - -(* Store the node_info and hostname for each connection, fetched - * once just after we connect since these don't normally change. - * Hash of connid -> (C.node_info, hostname option, uri) - *) -let static_conn_info = Hashtbl.create 13 - -let open_connection uri = - (* If this fails, let the exception escape and be printed - * in the global exception handler. - *) - let conn = C.connect ~name:uri () in - - let node_info = C.get_node_info conn in - let hostname = - try Some (C.get_hostname conn) - with - | Libvirt.Not_supported "virConnectGetHostname" - | Libvirt.Virterror _ -> None in - - (* Add it to our list of connections. *) - let conn_id = add_conn conn in - Hashtbl.add static_conn_info conn_id (node_info, hostname, uri) - -(* Stores the state and history for each domain. - * Hash of (connid, domid) -> mutable domhistory structure. - * We never delete entries in this hash table, which may be a problem - * for very very long-lived instances of virt-ctrl. - *) -type domhistory = { - (* for %CPU calculation: *) - mutable last_cpu_time : int64; (* last virDomainInfo->cpuTime *) - mutable last_time : float; (* exact time we measured the above *) - - (* historical data for graphs etc: *) - mutable hist : dhentry array; (* historical data *) - mutable hist_posn : int; (* position within array *) -} -and dhentry = { - hist_cpu : int; (* historical %CPU entry *) - hist_mem : int64; (* historical memory entry (KB) *) -} - -let domhistory = Hashtbl.create 13 - -let empty_dhentry = { - hist_cpu = 0; hist_mem = 0L; -} -let new_domhistory () = { - last_cpu_time = 0L; last_time = 0.; - hist = Array.make 0 empty_dhentry; hist_posn = 0; -} - -(* These set limits on the amount of history we collect. *) -let hist_max = 86400 (* max history stored, seconds *) -let hist_rot = 3600 (* rotation of array when we hit max *) - -(* The current state. This is used so that we can see changes that - * have happened and add or remove parts of the model. (Previously - * we used to recreate the whole model each time, but the problem - * with that is we "forget" things like the selection). - *) -type state = connection list -and connection = int (* connection ID *) * (active list * inactive list) -and active = int (* domain's ID *) -and inactive = string (* domain's name *) - -(* The types of the display columns in the main window. The interesting - * one of the final (int) field which stores the ID of the row, either - * connid or domid. - *) -type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column - -let debug_repopulate = false - -(* Populate the tree with the current list of connections, domains. - * This function is called once per second. - *) -let repopulate (tree : GTree.view) (model : GTree.tree_store) - (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id) - state = - (* Which connections have been added or removed? *) - let conns = get_conns () in - let added, _, removed = - let old_conn_ids = List.map fst state - and new_conn_ids = List.map fst conns in - differences old_conn_ids new_conn_ids in - - (* Remove the subtrees for any connections which have gone. *) - if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed; - - List.iter ( - fun conn_id -> - filter_top_level_rows model - (fun row -> conn_id <> model#get ~row ~column:col_id) - ) removed; - - (* Add placeholder subtree for any new connections. *) - if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added; - - List.iter ( - fun conn_id -> - let row = model#append () in - (* Get the connection name, usually the hostname. *) - let name = - match Hashtbl.find static_conn_info conn_id with - | (_, Some hostname, _) -> hostname - | (_, None, _) -> sprintf "Conn #%d" conn_id in - model#set ~row ~column:col_name_id name; - model#set ~row ~column:col_id conn_id; - (* Expand the new row. *) - (* XXX This doesn't work, why? - Because we haven't create subrows yet.*) - tree#expand_row (model#get_path row) - ) added; - - let new_state = - List.map ( - fun (conn_id, conn) -> - (* Get the old list of active and inactive domains. If this - * connection is newly created, start with empty lists. - *) - let old_active, old_inactive = - try List.assoc conn_id state - with Not_found -> [], [] in - - (* Get the top level row in the model corresponding to this - * connection. - *) - let parent = - try find_top_level_row model - (fun row -> conn_id = model#get ~row ~column:col_id) - with Not_found -> assert false (* Should never happen. *) in - - try - (* Number of CPUs available. *) - let node_info, _, _ = Hashtbl.find static_conn_info conn_id in - let nr_cpus = C.maxcpus_of_node_info node_info in - - (* For this connection, get a current list of active domains (IDs) *) - let active = - let n = C.num_of_domains conn in - let doms = C.list_domains conn n in - Array.to_list doms in - - (* Which active domains have been added or removed? *) - let added, _, removed = differences old_active active in - - (* Remove any active domains which have disappeared. *) - if debug_repopulate then - List.iter (eprintf "-active %d\n%!") removed; - - List.iter ( - fun domid -> - filter_rows model - (fun row -> domid <> model#get ~row ~column:col_id) - (model#iter_children (Some parent)) - ) removed; - - (* Add any active domains which have appeared. *) - if debug_repopulate then - List.iter (eprintf "+active %d\n%!") added; - - List.iter ( - fun domid -> - let domname = - try - let dom = D.lookup_by_id conn domid in - D.get_name dom - with _ -> "" in (* Ignore any transient error. *) - - let row = model#append ~parent () in - model#set ~row ~column:col_name_id (string_of_int domid); - model#set ~row ~column:col_domname domname; - model#set ~row ~column:col_id domid - ) added; - - (* Get a current list of inactive domains (names). *) - let inactive = - let n = C.num_of_defined_domains conn in - let doms = C.list_defined_domains conn n in - Array.to_list doms in - - (* Which inactive domains have been added or removed? *) - let added, _, removed = differences old_inactive inactive in - - (* Remove any inactive domains which have disappeared. *) - if debug_repopulate then - List.iter (eprintf "-inactive %s\n%!") removed; - - List.iter ( - fun domname -> - filter_rows model - (fun row -> - model#get ~row ~column:col_id <> -1 || - model#get ~row ~column:col_domname <> domname) - (model#iter_children (Some parent)) - ) removed; - - (* Add any inactive domains which have appeared. *) - if debug_repopulate then - List.iter (eprintf "+inactive %s\n%!") added; - - List.iter ( - fun domname -> - let row = model#append ~parent () in - model#set ~row ~column:col_name_id ""; - model#set ~row ~column:col_domname domname; - model#set ~row ~column:col_status "inactive"; - model#set ~row ~column:col_id (-1) - ) added; - - (* Now iterate over all active domains and update their state, - * CPU and memory. - *) - iter_rows model ( - fun row -> - let domid = model#get ~row ~column:col_id in - if domid >= 0 then ( (* active *) - try - let dom = D.lookup_by_id conn domid in - let info = D.get_info dom in - let status = string_of_domain_state info.D.state in - model#set ~row ~column:col_status status; - let memory = sprintf "%Ld K" info.D.memory in - model#set ~row ~column:col_mem memory; - - (* Get domhistory. For a new domain it won't exist, so - * create an empty one. - *) - let dh = - let key = conn_id, domid in - try Hashtbl.find domhistory key - with Not_found -> - let dh = new_domhistory () in - Hashtbl.add domhistory key dh; - dh in - - (* Measure current time and domain cpuTime as close - * together as possible. - *) - let time_now = Unix.gettimeofday () in - let cpu_now = info.D.cpu_time in - - let time_prev = dh.last_time in - let cpu_prev = - if dh.last_cpu_time > cpu_now then 0L (* Rebooted? *) - else dh.last_cpu_time in - - dh.last_time <- time_now; - dh.last_cpu_time <- cpu_now; - - let cpu_percent = - if time_prev > 0. then ( - let cpu_now = Int64.to_float cpu_now in - let cpu_prev = Int64.to_float cpu_prev in - let cpu_used = cpu_now -. cpu_prev in - let cpu_available = 1_000_000_000. *. float nr_cpus in - let time_passed = time_now -. time_prev in - - let cpu_percent = - 100. *. (cpu_used /. cpu_available) /. time_passed in - - let cpu_percent = - if cpu_percent < 0. then 0. - else if cpu_percent > 100. then 100. - else cpu_percent in - - let cpu_percent_str = sprintf "%.1f %%" cpu_percent in - model#set ~row ~column:col_cpu cpu_percent_str; - int_of_float cpu_percent - ) else -1 in - - (* Store history. *) - let datum = { hist_cpu = cpu_percent; - hist_mem = info.D.memory } in - - if dh.hist_posn >= hist_max then ( - (* rotate the array *) - Array.blit dh.hist hist_rot dh.hist 0 (hist_max-hist_rot); - dh.hist_posn <- dh.hist_posn - hist_rot; - dh.hist.(dh.hist_posn) <- datum; - ) else ( - let len = Array.length dh.hist in - if dh.hist_posn < len then - (* normal update *) - dh.hist.(dh.hist_posn) <- datum - else ( - (* extend the array *) - let len' = min (max (2*len) 1) hist_max in - let arr' = Array.make len' datum in - Array.blit dh.hist 0 arr' 0 len; - dh.hist <- arr'; - ) - ); - dh.hist_posn <- dh.hist_posn+1 - - with - Libvirt.Virterror _ -> () (* Ignore any transient error *) - ) - ) (model#iter_children (Some parent)); - - (* Return new state. *) - conn_id, (active, inactive) - with - (* Libvirt errors here are not really fatal. They can happen - * if the state changes at the moment we read it. If it does - * happen, just return the old state, and next time we come - * around to this connection it'll be fixed. - *) - | Libvirt.Virterror err -> - prerr_endline (Libvirt.Virterror.to_string err); - conn_id, (old_active, old_inactive) - | Failure msg -> - prerr_endline msg; - conn_id, (old_active, old_inactive) - ) conns in - - (* Return the updated state. *) - new_state - -(* Make the treeview which displays the connections and domains. *) -let make_treeview ?packing () = - let cols = new GTree.column_list in - let col_name_id = cols#add Gobject.Data.string in - let col_domname = cols#add Gobject.Data.string in - let col_status = cols#add Gobject.Data.string in - let col_cpu = cols#add Gobject.Data.string in - let col_mem = cols#add Gobject.Data.string in - (* Hidden column containing the connection ID or domain ID. For - * inactive domains, this contains -1 and col_domname is the name. *) - let col_id = cols#add Gobject.Data.int in - let model = GTree.tree_store cols in - - (* Column sorting functions. *) - let make_sort_func_on column = - fun (model : GTree.model) row1 row2 -> - let col1 = model#get ~row:row1 ~column in - let col2 = model#get ~row:row2 ~column in - compare col1 col2 - in - (*model#set_default_sort_func (make_sort_func_on col_domname);*) - model#set_sort_func 0 (make_sort_func_on col_name_id); - model#set_sort_func 1 (make_sort_func_on col_domname); - model#set_sort_column_id 1 `ASCENDING; - - (* Make the GtkTreeView and attach column renderers to it. *) - let tree = GTree.view ~model ~reorderable:false ?packing () in - - let append_visible_column title column sort = - let renderer = GTree.cell_renderer_text [], ["text", column] in - let view_col = GTree.view_column ~title ~renderer () in - ignore (tree#append_column view_col); - match sort with - | None -> () - | Some (sort_indicator, sort_order, sort_column_id) -> - view_col#set_sort_indicator sort_indicator; - view_col#set_sort_order sort_order; - view_col#set_sort_column_id sort_column_id - in - append_visible_column (s_ "ID") col_name_id (Some (false, `ASCENDING, 0)); - append_visible_column (s_ "Name") col_domname (Some (true, `ASCENDING, 1)); - append_visible_column (s_ "Status") col_status None; - append_visible_column (s_ "CPU") col_cpu None; - append_visible_column (s_ "Memory") col_mem None; - - let columns = - col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in - let state = repopulate tree model columns [] in - - (tree, model, columns, state) - -(* Get historical data size. *) -let get_hist_size connid domid = - try - let dh = Hashtbl.find domhistory (connid, domid) in - dh.hist_posn - with - Not_found -> 0 - -(* Get historical data entries. *) -let _get_hist ?(latest=0) ?earliest ?(granularity=1) - extract fold zero connid domid = - try - let dh = Hashtbl.find domhistory (connid, domid) in - let earliest = - match earliest with - | None -> dh.hist_posn - | Some e -> min e dh.hist_posn in - - let src = dh.hist in - let src_start = dh.hist_posn - earliest in assert (src_start >= 0); - let src_end = dh.hist_posn - latest in assert (src_end <= dh.hist_posn); - - (* Create a sufficiently large array to store the result. *) - let len = (earliest-latest) / granularity in - let r = Array.make len zero in - - if granularity = 1 then ( - for j = 0 to len-1 do - r.(j) <- extract src.(src_start+j) - done - ) else ( - let i = ref src_start in - for j = 0 to len-1 do - let sub = Array.sub src !i (min (!i+granularity) src_end - !i) in - let sub = Array.map extract sub in - r.(j) <- fold sub; - i := !i + granularity - done - ); - r - with - Not_found -> [| |] - -let get_hist_cpu ?latest ?earliest ?granularity connid domid = - let zero = 0 in - let extract { hist_cpu = c } = c in - let fold a = - let len = Array.length a in - if len > 0 then Array.fold_left (+) zero a / len else -1 in - _get_hist ?latest ?earliest ?granularity extract fold zero connid domid - -let get_hist_mem ?latest ?earliest ?granularity connid domid = - let zero = 0L in - let extract { hist_mem = m } = m in - let fold a = - let len = Array.length a in - if len > 0 then - Int64.div (Array.fold_left (Int64.add) zero a) (Int64.of_int len) - else - -1L in - _get_hist ?latest ?earliest ?granularity extract fold zero connid domid diff --git a/virt-ctrl/vc_connections.mli b/virt-ctrl/vc_connections.mli deleted file mode 100644 index 261f853..0000000 --- a/virt-ctrl/vc_connections.mli +++ /dev/null @@ -1,102 +0,0 @@ -(* 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. - - Handle connections and the complicated GtkTreeView which - displays the connections / domains. -*) - -(** Get the list of current connections. *) -val get_conns : unit -> (int * Libvirt.rw Libvirt.Connect.t) list - -(** The current/previous state last time repopulate was called. The - repopulate function uses this state to determine what has changed - (eg. domains added, removed) since last time. -*) -type state - -type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column - -(** This function should be called once per second in order to - redraw the GtkTreeView. - - Takes the previous state as a parameter and returns the new state. -*) -val repopulate : GTree.view -> GTree.tree_store -> columns -> state -> state - -(** Create the GtkTreeView. Returns the widget itself, the model, - the list of columns, and the initial state. -*) -val make_treeview : - ?packing:(GObj.widget -> unit) -> unit -> - GTree.view * GTree.tree_store * columns * state - -(** Open a new connection to the hypervisor URI given. *) -val open_connection : string -> unit - -(** Return the amount of historical data that we hold about a - domain (in seconds). - - The parameters are connection ID (see {!get_conns}) and domain ID. - - This can return from [0] to [86400] (or 1 day of data). -*) -val get_hist_size : int -> int -> int - -(** Return a slice of historical %CPU data about a domain. - - The required parameters are connection ID (see {!get_conns}) - and domain ID. - - The optional [latest] parameter is the latest data we should - return. It defaults to [0] meaning to return everything up to now. - - The optional [earliest] parameter is the earliest data we should - return. This is a positive number representing number of seconds - back in time. It defaults to returning all data. - - The optional [granularity] parameter is the granularity of data - that we should return, in seconds. This defaults to [1], meaning - to return all data (once per second), but you might for example - set this to [60] to return data for each minute. - - This returns an array of data. The first element of the array is - the oldest data. The last element of the array is the most recent - data. The array returned might be shorter than you expect (if - data is missing or for some other reason) so always check the - length. - - Entries in the array are clamped to [0..100], except that if an - entry is [-1] it means "no data". - - This returns a zero-length array if we don't know about the domain. -*) -val get_hist_cpu : ?latest:int -> ?earliest:int -> ?granularity:int -> - int -> int -> - int array - -(** Return a slice of historical memory data about a domain. - - Parameters as above. - - Entries in the array are 64 bit integers corresponding to the - amount of memory in KB allocated to the domain (not necessarily - the amount being used, which we don't know about). -*) -val get_hist_mem : ?latest:int -> ?earliest:int -> ?granularity:int -> - int -> int -> - int64 array diff --git a/virt-ctrl/vc_dbus.ml b/virt-ctrl/vc_dbus.ml deleted file mode 100644 index 82b66dd..0000000 --- a/virt-ctrl/vc_dbus.ml +++ /dev/null @@ -1,317 +0,0 @@ -(* 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. - - This file contains any code which needs optional package OCaml-DBUS. -*) - -(* There is *zero* documentation for this. I examined a lot of code - * to do this, and the following page was also very helpful: - * http://www.amk.ca/diary/2007/04/rough_notes_python_and_dbus.html - * See also the DBus API reference: - * http://dbus.freedesktop.org/doc/dbus/api/html/index.html - * See also Dan Berrange's Perl bindings: - * http://search.cpan.org/src/DANBERR/Net-DBus-0.33.5/lib/Net/ - * - * This code is a complicated state machine because that's what - * D-Bus requires. Enable debugging below to trace messages. - * - * It's also very unelegant and leaks memory. - * - * The code connects to D-Bus only the first time that the - * connection dialog is opened, and thereafter it attaches itself - * to the Gtk main loop, waiting for events. It's probably not - * safe if the avahi or dbus daemon restarts. - *) - -open Printf -open Virt_ctrl_gettext.Gettext -open DBus - -let debug = true - -let service = "_libvirt._tcp" - -let rec print_msg msg = - (match Message.get_type msg with - | Message.Invalid -> - eprintf "Invalid"; - | Message.Method_call -> - eprintf "Method_call"; - | Message.Method_return -> - eprintf "Method_return"; - | Message.Error -> - eprintf "Error"; - | Message.Signal -> - eprintf "Signal"); - - let print_opt f name = - match f msg with - | None -> () - | Some value -> eprintf "\n\t%s=%S" name value - in - print_opt Message.get_member "member"; - print_opt Message.get_path "path"; - print_opt Message.get_interface "interface"; - print_opt Message.get_sender "sender"; - - let fields = Message.get msg in - eprintf "\n\t["; - print_fields fields; - eprintf "]\n%!"; - -and print_fields fields = - eprintf "%s" (String.concat ", " (List.map string_of_ty fields)) - -(* Perform a synchronous call to an object method. *) -let call_method ~bus ~err ~name ~path ~interface ~methd args = - (* Create the method_call message. *) - let msg = Message.new_method_call name path interface methd in - Message.append msg args; - (* Send the message, get reply. *) - let r = Connection.send_with_reply_and_block bus msg (-1) err in - Message.get r - -(* Services we've found. - * This is a map from name -> URI. - * XXX We just assume Xen at the moment. - * XXX The same machine can appear on multiple interfaces, so this - * isn't right. - *) -let services : (string, string) Hashtbl.t = Hashtbl.create 13 - -(* Process a Found message, indicating that we've found and fully - * resolved a new service. - *) -let add_service bus err msg = - (* match fields in the Found message from ServiceResolver. *) - match Message.get msg with - | Int32 _ :: (* interface *) - Int32 (*protocol*)_ :: (* 0 = IPv4, 1=IPv6 *) - String name :: (* "Virtualization Host foo" *) - String _ :: (* "_libvirt._tcp" *) - String _ :: (* domain name *) - String hostname :: (* this is the hostname as a string *) - Int32 _ :: (* ? aprotocol *) - String address :: (* IP address as a string *) - UInt16 (*port*)_ :: _ -> (* port is set to 0 by libvirtd *) - - let hostname = if hostname <> "" then hostname else address in - (*let protocol = if protocol = 1_l then IPv6 else IPv4 in*) - - (* XXX *) - let uri = "xen://" ^ hostname ^ "/" in - - if debug then eprintf "adding %s %s\n%!" name uri; - - Hashtbl.replace services name uri - - | _ -> - prerr_endline (s_ "warning: unexpected message contents of Found signal") - -(* Process an ItemRemove message, indicating that a service has - * gone away. - *) -let remove_service bus err msg = - (* match fields in the ItemRemove message from ServiceBrowser. *) - match Message.get msg with - | Int32 _ :: (* interface *) - Int32 _ :: (* protocol *) - String name :: _ -> (* name *) - if debug then eprintf "removing %s\n%!" name; - Hashtbl.remove services name - - | _ -> - prerr_endline - (s_ "warning: unexpected message contents of ItemRemove signal") - -(* A service has appeared on the network. Resolve its IP address, etc. *) -let start_resolve_service bus err sb_path msg = - (* match fields in the ItemNew message from ServiceBrowser. *) - match Message.get msg with - | ((Int32 _) as interface) :: - ((Int32 _) as protocol) :: - ((String _) as name) :: - ((String _) as service) :: - ((String _) as domain) :: _ -> - (* Create a new ServiceResolver object which is used to resolve - * the actual locations of network services found by the ServiceBrowser. - *) - let sr = - call_method ~bus ~err - ~name:"org.freedesktop.Avahi" - ~path:"/" - ~interface:"org.freedesktop.Avahi.Server" - ~methd:"ServiceResolverNew" - [ - interface; - protocol; - name; - service; - domain; - Int32 (-1_l); (* AVAHI_PROTO_UNSPEC *) - UInt32 0_l; (* flags *) - ] in - let sr_path = - match sr with - | [ ObjectPath path ] -> path - | _ -> assert false in - - if debug then eprintf "ServiceResolver path = %S\n%!" sr_path; - - (* Add a match rule so we see these all signals of interest. *) - Bus.add_match bus - (String.concat "," [ - "type='signal'"; - "sender='org.freedesktop.Avahi.ServiceResolver'"; - "path='" ^ sr_path ^ "'"; - ]) err; - - () - - | _ -> - prerr_endline - (s_ "warning: unexpected message contents of ItemNew signal") - -(* This is called when we get a message/signal. Could be from the - * (global) ServiceBrowser or any of the ServiceResolver objects. - *) -let got_message bus err sb_path msg = - if debug then print_msg msg; - - let typ = Message.get_type msg in - let member = match Message.get_member msg with None -> "" | Some m -> m in - let interface = - match Message.get_interface msg with None -> "" | Some m -> m in - - if typ = Message.Signal then ( - match interface, member with - | "org.freedesktop.Avahi.ServiceBrowser", "CacheExhausted" -> () - | "org.freedesktop.Avahi.ServiceBrowser", "AllForNow" -> () - | "org.freedesktop.Avahi.ServiceBrowser", "ItemNew" -> - (* New service has appeared, start to resolve it. *) - start_resolve_service bus err sb_path msg - | "org.freedesktop.Avahi.ServiceResolver", "Found" -> - (* Resolver has finished resolving the name of a previously - * appearing service. - *) - add_service bus err msg - | "org.freedesktop.Avahi.ServiceBrowser", "ItemRemove" -> - (* Service has disappeared. *) - remove_service bus err msg - | "org.freedesktop.DBus", _ -> () - | interface, member -> - let () = - eprintf (f_ "warning: ignored unknown message %s from %s\n%!") - member interface in - () - ); - true - -(* Store the connection ((bus, err, io_id) tuple). However don't bother - * connecting to D-Bus at all until the user opens the connection - * dialog for the first time. - *) -let connection = ref None - -(* Create global error and system bus object, and create the service browser. *) -let connect () = - match !connection with - | Some (bus, err, _) -> (bus, err, false) - | None -> - let err = Error.init () in - let bus = Bus.get Bus.System err in - if Error.is_set err then - failwith (s_ "error set after getting System bus"); - - (* Create a new ServiceBrowser object which emits a signal whenever - * a new network service of the type specified is found on the network. - *) - let sb = - call_method ~bus ~err - ~name:"org.freedesktop.Avahi" - ~path:"/" - ~interface:"org.freedesktop.Avahi.Server" - ~methd:"ServiceBrowserNew" - [ - Int32 (-1_l); (* interface, -1=AVAHI_IF_UNSPEC *) - Int32 (-1_l); (* AVAHI_PROTO_UNSPEC *) - String service; (* service type *) - String ""; (* XXX call GetDomainName() *) - UInt32 0_l; (* flags *) - ] in - let sb_path = - match sb with - | [ ObjectPath path ] -> path - | _ -> assert false in - - if debug then eprintf "ServiceBrowser path = %S\n%!" sb_path; - - (* Register a callback to accept the signals. *) - (* XXX This leaks memory because it is never freed. *) - Connection.add_filter bus ( - fun bus msg -> got_message bus err sb_path msg - ); - - (* Add a match rule so we see these all signals of interest. *) - Bus.add_match bus - (String.concat "," [ - "type='signal'"; - "sender='org.freedesktop.Avahi.ServiceBrowser'"; - "path='" ^ sb_path ^ "'"; - ]) err; - - (* This is called from the Gtk main loop whenever there is new - * data to read on the D-Bus socket. - *) - let callback _ = - if debug then eprintf "dbus callback\n%!"; - if Connection.read_write_dispatch bus 0 then true - else ( (* Disconnected. *) - connection := None; - false - ) - in - - (* Get the file descriptor and attach to the Gtk main loop. *) - let fd = Connection.get_fd bus in - let channel = GMain.Io.channel_of_descr fd in - let io_id = GMain.Io.add_watch ~cond:[`IN] ~callback channel in - - connection := Some (bus, err, io_id); - (bus, err, true) - -(* This function is called by the connection dialog and is expected - * to return a list of services we know about now. - *) -let find_services () = - let bus, err, just_connected = connect () in - - (* If we've just connected, wait briefly for the list to stablise. *) - if just_connected then ( - let start_time = Unix.gettimeofday () in - while Unix.gettimeofday () -. start_time < 0.5 do - ignore (Connection.read_write_dispatch bus 500) - done - ); - - (* Return the services we know about. *) - Hashtbl.fold (fun k v vs -> (k, v) :: vs) services [] - -;; - -Vc_connection_dlg.find_libvirtd_with_zeroconf := find_services diff --git a/virt-ctrl/vc_dbus.mli b/virt-ctrl/vc_dbus.mli deleted file mode 100644 index 884093e..0000000 --- a/virt-ctrl/vc_dbus.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* 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. - - This file contains any code which needs optional package OCaml-DBUS. -*) - -(* No public API. If loaded this module hooks into Vc_connection_dlg. *) diff --git a/virt-ctrl/vc_domain_ops.ml b/virt-ctrl/vc_domain_ops.ml deleted file mode 100644 index deace05..0000000 --- a/virt-ctrl/vc_domain_ops.ml +++ /dev/null @@ -1,109 +0,0 @@ -(* 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. - - Domain operations buttons. -*) - -open Printf -open Virt_ctrl_gettext.Gettext - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -(* Get the selected domain (if there is one) or return None. *) -let get_domain (tree : GTree.view) (model : GTree.tree_store) - (columns : Vc_connections.columns) = - let path, _ = tree#get_cursor () in - match path with - | None -> None (* No row at all selected. *) - | Some path -> - let row = model#get_iter path in - (* Visit parent to get the connid. - * If this returns None, then it's a top-level row which is - * selected (ie. a connection), so just ignore. - *) - match model#iter_parent row with - | None -> None - | Some parent -> - try - let (_, col_domname, _, _, _, col_id) = columns in - let connid = model#get ~row:parent ~column:col_id in - let conn = - List.assoc connid (Vc_connections.get_conns ()) in - let domid = model#get ~row ~column:col_id in - if domid = -1 then ( (* Inactive domain. *) - let domname = model#get ~row ~column:col_domname in - let dom = D.lookup_by_name conn domname in - let info = D.get_info dom in - Some (dom, info, connid, -1) - ) else ( (* Active domU. *) - let dom = D.lookup_by_id conn domid in - let info = D.get_info dom in - Some (dom, info, connid, domid) - ) - with - (* Domain or connection disappeared under us. *) - | Not_found -> None - | Failure msg -> - prerr_endline msg; - None - | Libvirt.Virterror err -> - prerr_endline (Libvirt.Virterror.to_string err); - None - -type dops_callback_fn = - GTree.view -> GTree.tree_store -> Vc_connections.columns -> unit -> unit - -let start_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, _, _, domid) -> - if domid = -1 then - D.create dom - -let pause_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, _, domid) -> - if domid >= 0 && info.D.state <> D.InfoPaused then - D.suspend dom - -let resume_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, _, domid) -> - if domid >= 0 && info.D.state = D.InfoPaused then - D.resume dom - -let shutdown_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, _, domid) -> - if domid >= 0 && info.D.state <> D.InfoShutdown then - D.shutdown dom - -let open_domain_details tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, connid, domid) -> - if domid >= 0 then ( - - - - ) diff --git a/virt-ctrl/vc_domain_ops.mli b/virt-ctrl/vc_domain_ops.mli deleted file mode 100644 index 38a2015..0000000 --- a/virt-ctrl/vc_domain_ops.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* 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. - - Domain operations buttons. -*) - -type dops_callback_fn = - GTree.view -> GTree.tree_store -> Vc_connections.columns -> unit -> unit - (** Domain ops callback function type. - - The parameters are: tree (view), model, columns. - The extra unit parameter is there to make it easier to - turn into a callback. - *) - -val start_domain : dops_callback_fn -val pause_domain : dops_callback_fn -val resume_domain : dops_callback_fn -val shutdown_domain : dops_callback_fn -val open_domain_details : dops_callback_fn diff --git a/virt-ctrl/vc_helpers.ml b/virt-ctrl/vc_helpers.ml deleted file mode 100644 index 74e70cb..0000000 --- a/virt-ctrl/vc_helpers.ml +++ /dev/null @@ -1,97 +0,0 @@ -(* 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 - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -(* Given two lists, xs and ys, return a list of items which have been - * added to ys, items which are the same, and items which have been - * removed from ys. - * Returns a triplet (list of added, list of same, list of removed). - *) -let differences xs ys = - let rec d = function - | [], [] -> (* Base case. *) - ([], [], []) - | [], ys -> (* All ys have been added. *) - (ys, [], []) - | xs, [] -> (* All xs have been removed. *) - ([], [], xs) - | (x :: xs), (y :: ys) when x = y -> (* Not added or removed. *) - let added, unchanged, removed = d (xs, ys) in - added, x :: unchanged, removed - | (x :: xs), ((y :: _) as ys) when x < y -> (* x removed. *) - let added, unchanged, removed = d (xs, ys) in - added, unchanged, x :: removed - | ((x :: _) as xs), (y :: ys) (* when x > y *) -> (* y added. *) - let added, unchanged, removed = d (xs, ys) in - y :: added, unchanged, removed - in - d (List.sort compare xs, List.sort compare ys) - -let string_of_domain_state = function - | D.InfoNoState -> s_ "unknown" - | D.InfoRunning -> s_ "running" - | D.InfoBlocked -> s_ "blocked" - | D.InfoPaused -> s_ "paused" - | D.InfoShutdown -> s_ "shutdown" - | D.InfoShutoff -> s_ "shutoff" - | D.InfoCrashed -> s_ "crashed" - -(* Filter top level rows (only) in a tree_store. If function f returns - * true then the row remains, but if it returns false then the row is - * removed. - *) -let rec filter_top_level_rows (model : GTree.tree_store) f = - match model#get_iter_first with - | None -> () - | Some iter -> filter_rows model f iter - -(* Filter rows in a tree_store at a particular level. *) -and filter_rows model f row = - let keep = f row in - let iter_still_valid = - if not keep then model#remove row else model#iter_next row in - if iter_still_valid then filter_rows model f row - -(* Find the first top level row matching predicate f and return it. *) -let rec find_top_level_row (model : GTree.tree_store) f = - match model#get_iter_first with - | None -> raise Not_found (* no rows *) - | Some row -> find_row model f row - -(* Find the first row matching predicate f at a particular level. *) -and find_row model f row = - if f row then row - else if model#iter_next row then find_row model f row - else raise Not_found - -(* Iterate over top level rows (only) in a tree_store. *) -let rec iter_top_level_rows (model : GTree.tree_store) f = - match model#get_iter_first with - | None -> () - | Some iter -> iter_rows model f iter - -(* Iterate over rows in a tree_store at a particular level. *) -and iter_rows model f row = - f row; - if model#iter_next row then iter_rows model f row diff --git a/virt-ctrl/vc_helpers.mli b/virt-ctrl/vc_helpers.mli deleted file mode 100644 index b533024..0000000 --- a/virt-ctrl/vc_helpers.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* 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. - - Helper functions. -*) - -(** Given two lists, xs and ys, return a list of items which have been - added to ys, items which are the same, and items which have been - removed from ys. - Returns a triplet (list of added, list of same, list of removed). -*) -val differences : 'a list -> 'a list -> 'a list * 'a list * 'a list - -(** Convert libvirt domain state to a string. *) -val string_of_domain_state : Libvirt.Domain.state -> string - -(** Filter top level rows (only) in a GtkTreeStore. If function f returns - true then the row remains, but if it returns false then the row is - removed. -*) -val filter_top_level_rows : GTree.tree_store -> (Gtk.tree_iter -> bool) -> unit - -(** Filter rows in a tree_store at a particular level. *) -val filter_rows : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter -> unit - -(** Find the first top level row matching predicate and return it. *) -val find_top_level_row : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter - -(** Find the first row matching predicate f at a particular level. *) -val find_row : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter -> Gtk.tree_iter - -(** Iterate over top level rows (only) in a GtkTreeStore. *) -val iter_top_level_rows : GTree.tree_store -> (Gtk.tree_iter -> unit) -> unit - -(** Iterate over rows in a tree_store at a particular level. *) -val iter_rows : GTree.tree_store -> (Gtk.tree_iter -> unit) -> Gtk.tree_iter -> unit diff --git a/virt-ctrl/vc_icons.ml b/virt-ctrl/vc_icons.ml deleted file mode 100644 index 911e487..0000000 --- a/virt-ctrl/vc_icons.ml +++ /dev/null @@ -1,270 +0,0 @@ - - -open Vc_connection_dlg - - -let pixbuf_data = "\ -\132\149\166\190\000\000\010\192\000\000\000\001\000\000\000\003\000\000\000\003\ -\018\071\100\107\080\105\120\098\117\102\047\050\046\048\047\000\000\000\010\172\ -\071\100\107\080\000\000\010\172\002\001\000\002\000\000\000\128\000\000\000\032\ -\000\000\000\032\161\255\255\255\000\003\136\138\133\023\140\142\137\150\138\140\ -\135\247\152\136\138\133\255\003\138\140\135\246\140\142\137\156\136\138\133\030\ -\130\255\255\255\000\003\141\143\138\165\190\191\188\251\249\249\249\255\152\255\ -\255\255\255\009\248\248\247\255\194\196\192\253\141\143\138\165\255\255\255\000\ -\136\138\133\010\139\141\136\246\250\250\249\255\128\152\186\255\033\075\135\255\ -\150\032\074\135\255\010\033\075\135\255\113\140\178\255\244\245\246\255\139\141\ -\136\246\136\138\133\009\136\138\133\024\141\143\138\246\255\255\255\255\033\075\ -\135\255\160\182\205\255\130\173\191\212\255\134\173\192\212\255\131\174\193\213\ -\255\134\175\193\213\255\134\176\194\213\255\003\041\081\139\255\255\255\255\255\ -\141\143\138\246\130\136\138\133\024\004\141\143\138\246\255\255\255\255\032\074\ -\135\255\154\177\202\255\151\164\185\208\255\003\040\080\139\255\255\255\255\255\ -\141\143\138\246\130\136\138\133\024\004\141\143\138\246\255\255\255\255\032\074\ -\135\255\144\169\197\255\151\153\176\202\255\003\040\080\139\255\255\255\255\255\ -\141\143\138\246\130\136\138\133\024\004\141\143\138\246\255\255\255\255\032\074\ -\135\255\134\162\192\255\151\142\168\196\255\003\040\080\139\255\255\255\255\255\ -\141\143\138\246\130\136\138\133\024\004\141\143\138\246\255\255\255\255\032\074\ -\135\255\123\154\186\255\134\131\159\190\255\002\132\160\190\255\133\161\191\255\ -\130\133\161\192\255\003\134\162\192\255\134\162\193\255\134\162\192\255\131\133\ -\161\192\255\001\132\160\190\255\132\131\159\190\255\005\121\152\185\255\103\138\ -\176\255\040\080\139\255\255\255\255\255\141\143\138\246\130\136\138\133\024\004\ -\141\143\138\246\255\255\255\255\032\074\135\255\113\145\181\255\131\119\150\184\ -\255\007\121\152\185\255\122\153\187\255\123\154\188\255\125\155\189\255\125\156\ -\189\255\126\157\190\255\127\157\191\255\132\127\158\191\255\007\126\157\190\255\ -\125\156\189\255\123\155\188\255\105\140\178\255\088\127\169\255\072\114\160\255\ -\055\101\150\255\130\050\097\148\255\003\040\080\139\255\255\255\255\255\141\143\ -\138\246\130\136\138\133\024\030\141\143\138\246\255\255\255\255\032\074\135\255\ -\103\138\176\255\108\142\178\255\110\144\180\255\112\145\182\255\114\147\183\255\ -\115\149\185\255\117\150\186\255\118\151\187\255\119\152\188\255\120\153\189\255\ -\120\154\190\255\121\154\190\255\121\155\190\255\121\154\190\255\120\154\190\255\ -\115\149\186\255\091\131\174\255\068\113\163\255\062\109\159\255\060\107\157\255\ -\058\105\155\255\056\102\153\255\053\100\151\255\050\097\148\255\040\080\139\255\ -\255\255\255\255\141\143\138\246\130\136\138\133\024\030\141\143\138\246\255\255\ -\255\255\032\074\135\255\094\131\171\255\100\136\175\255\102\138\178\255\105\141\ -\179\255\107\142\181\255\108\145\183\255\111\146\185\255\112\148\186\255\113\149\ -\188\255\115\150\188\255\115\151\189\255\115\152\189\255\116\152\190\255\106\145\ -\185\255\088\130\176\255\073\119\169\255\071\118\168\255\070\116\166\255\068\114\ -\164\255\066\112\162\255\063\110\160\255\060\107\158\255\058\104\155\255\055\102\ -\152\255\040\080\139\255\255\255\255\255\141\143\138\246\130\136\138\133\024\030\ -\141\143\138\246\255\255\255\255\032\074\135\255\087\126\169\255\092\131\173\255\ -\096\133\175\255\098\136\178\255\101\138\180\255\102\141\182\255\105\143\184\255\ -\106\144\185\255\108\146\187\255\110\147\189\255\109\147\189\255\099\140\184\255\ -\086\131\179\255\081\127\177\255\080\126\176\255\079\125\175\255\077\124\173\255\ -\076\122\171\255\073\120\169\255\071\117\167\255\068\114\165\255\065\112\162\255\ -\062\109\159\255\059\106\156\255\040\081\139\255\255\255\255\255\141\143\138\246\ -\130\136\138\133\024\030\141\143\138\246\255\255\255\255\032\074\135\255\080\121\ -\166\255\085\126\170\255\088\129\173\255\091\132\175\255\094\134\178\255\096\137\ -\181\255\099\139\183\255\102\142\185\255\099\141\185\255\093\137\183\255\086\132\ -\182\255\087\133\182\255\088\134\183\255\087\133\183\255\087\132\182\255\085\131\ -\180\255\083\129\179\255\081\127\176\255\078\124\174\255\075\122\171\255\072\119\ -\169\255\069\116\166\255\066\112\163\255\062\109\159\255\040\081\139\255\255\255\ -\255\255\141\143\138\246\130\136\138\133\024\030\141\143\138\246\255\255\255\255\ -\032\074\135\255\073\117\164\255\077\121\168\255\081\124\171\255\084\128\174\255\ -\086\129\176\255\087\131\178\255\087\131\180\255\088\132\182\255\088\134\183\255\ -\091\136\185\255\093\138\187\255\094\139\188\255\094\140\189\255\094\140\188\255\ -\093\138\187\255\091\137\186\255\089\134\183\255\086\132\181\255\083\129\178\255\ -\080\126\175\255\076\122\172\255\073\119\169\255\069\115\166\255\065\112\162\255\ -\040\081\140\255\255\255\255\255\141\143\138\246\130\136\138\133\024\030\141\143\ -\138\246\255\255\255\255\032\074\135\255\063\110\160\255\067\114\164\255\071\117\ -\167\255\075\121\171\255\079\125\174\255\082\128\178\255\086\132\181\255\090\135\ -\184\255\093\139\187\255\096\141\190\255\098\144\193\255\100\146\194\255\101\146\ -\195\255\100\146\194\255\099\144\193\255\096\142\191\255\093\139\188\255\090\136\ -\185\255\086\132\182\255\083\129\178\255\079\125\175\255\075\121\171\255\071\118\ -\168\255\068\114\164\255\040\081\140\255\255\255\255\255\141\143\138\246\130\136\ -\138\133\024\030\141\143\138\246\255\255\255\255\032\074\135\255\065\111\161\255\ -\069\115\165\255\073\119\169\255\077\123\172\255\080\127\176\255\084\130\180\255\ -\088\134\183\255\092\138\187\255\096\142\190\255\100\145\194\255\103\149\197\255\ -\106\151\200\255\107\153\201\255\106\152\200\255\104\149\197\255\100\146\194\255\ -\096\142\191\255\093\138\187\255\089\135\184\255\085\131\180\255\081\127\176\255\ -\077\123\173\255\073\119\169\255\069\115\165\255\041\081\140\255\255\255\255\255\ -\141\143\138\246\130\136\138\133\024\030\141\143\138\246\255\255\255\255\032\074\ -\135\255\065\111\162\255\069\115\165\255\073\119\169\255\077\123\173\255\081\127\ -\177\255\085\131\180\255\089\135\184\255\093\139\188\255\097\143\191\255\101\147\ -\195\255\105\151\199\255\109\154\203\255\113\158\206\255\110\155\203\255\106\151\ -\199\255\102\147\196\255\098\143\192\255\094\139\188\255\090\135\184\255\086\131\ -\181\255\081\127\177\255\077\124\173\255\073\120\170\255\069\116\166\255\041\081\ -\140\255\255\255\255\255\141\143\138\246\130\136\138\133\024\006\141\143\138\246\ -\255\255\255\255\032\074\135\255\047\087\143\255\048\088\144\255\048\088\145\255\ -\130\049\089\145\255\130\050\090\146\255\130\051\091\147\255\001\052\091\148\255\ -\130\052\092\148\255\001\053\092\148\255\130\052\092\148\255\001\052\091\148\255\ -\130\051\091\147\255\130\050\090\146\255\130\049\089\145\255\005\048\088\145\255\ -\048\088\144\255\032\075\135\255\255\255\255\255\141\143\138\246\130\136\138\133\ -\024\005\141\143\138\246\255\255\255\255\198\206\214\255\197\205\214\255\196\204\ -\214\255\132\196\204\213\255\131\196\204\212\255\131\195\203\211\255\130\194\202\ -\211\255\132\194\202\210\255\134\193\201\210\255\007\192\200\209\255\254\254\254\ -\255\141\143\138\246\136\138\133\024\136\138\133\009\138\140\135\247\244\244\244\ -\255\151\254\254\254\255\131\255\255\255\255\006\247\247\246\255\138\140\135\248\ -\136\138\133\008\255\255\255\000\141\143\138\132\138\140\135\245\154\136\138\133\ -\255\002\138\140\135\245\141\143\138\149\135\255\255\255\000\025\000\000\000\001\ -\000\000\000\005\110\110\110\037\127\129\125\120\121\123\119\247\193\193\191\255\ -\203\203\201\255\205\205\204\255\207\207\206\255\210\210\208\255\213\213\211\255\ -\216\216\214\255\218\218\217\255\221\221\219\255\197\198\196\255\134\139\137\248\ -\121\146\173\203\110\153\198\187\112\156\204\189\113\156\204\192\113\158\205\195\ -\115\158\207\198\115\159\207\236\114\158\207\206\111\162\204\030\132\255\255\255\ -\000\008\000\000\000\002\000\000\000\007\000\000\000\011\000\000\000\015\124\126\ -\122\117\139\142\137\248\166\167\165\248\197\197\195\255\136\212\212\211\255\130\ -\211\211\211\255\011\185\185\185\255\156\157\154\246\138\140\134\244\082\082\078\ -\068\093\131\171\109\103\143\187\146\101\142\183\124\093\128\168\082\106\147\192\ -\147\112\156\204\205\000\000\000\002\130\255\255\255\000\008\000\000\000\003\000\ -\000\000\008\000\000\000\013\000\000\000\018\000\000\000\023\138\141\136\217\200\ -\200\197\255\251\251\251\255\140\254\254\254\255\010\241\241\241\255\174\176\172\ -\252\122\129\130\164\112\156\205\244\092\129\169\152\100\139\181\170\107\151\195\ -\206\112\157\203\235\106\147\192\187\000\000\000\011\130\255\255\255\000\006\000\ -\000\000\001\000\000\000\007\000\000\000\012\000\000\000\017\000\000\000\022\135\ -\137\132\208\132\137\139\134\248\138\137\139\134\249\130\137\139\134\248\008\123\ -\126\122\156\112\156\203\245\052\075\094\054\000\000\000\020\000\000\000\019\000\ -\000\000\020\000\000\000\015\000\000\000\002\130\255\255\255\000\003\136\138\133\ -\056\154\156\152\242\185\187\182\255\136\186\189\182\255\010\187\190\183\255\186\ -\189\182\255\187\190\184\255\186\189\182\255\188\191\184\255\186\188\182\255\184\ -\186\181\255\186\189\182\255\187\190\183\255\186\189\182\255\130\186\188\183\255\ -\006\186\189\182\255\187\190\183\255\185\188\181\255\182\183\179\255\140\142\137\ -\238\136\138\133\053\130\255\255\255\000\030\136\138\133\010\148\150\145\234\225\ -\226\224\255\199\201\196\255\211\215\207\255\217\220\213\255\211\215\207\255\219\ -\222\215\255\211\215\207\255\220\223\217\255\211\215\207\255\221\224\218\255\211\ -\215\207\255\222\225\219\255\211\215\207\255\223\226\221\255\211\215\207\255\208\ -\211\206\255\207\209\202\255\203\205\200\255\186\189\182\255\204\206\201\255\190\ -\194\187\255\206\208\202\255\214\216\211\255\211\215\207\255\220\222\217\255\188\ -\191\184\255\227\227\224\255\141\143\138\216\130\255\255\255\000\067\138\140\135\ -\151\212\212\210\251\190\193\186\255\207\210\202\255\224\226\221\255\211\215\207\ -\255\226\228\223\255\211\215\207\255\228\231\226\255\211\215\207\255\230\232\228\ -\255\211\215\207\255\232\234\230\255\211\215\207\255\234\236\232\255\211\215\207\ -\255\235\237\233\255\189\193\186\255\218\219\214\255\191\195\188\255\220\222\218\ -\255\187\190\183\255\228\230\226\255\211\213\207\255\194\197\190\255\232\234\230\ -\255\211\215\207\255\227\228\225\255\218\220\216\255\165\167\163\246\136\138\133\ -\076\136\138\133\050\151\153\148\247\238\238\237\255\187\190\183\255\210\212\207\ -\255\186\189\182\255\214\216\212\255\186\189\182\255\219\220\216\255\186\189\182\ -\255\223\224\221\255\186\189\182\255\227\229\226\255\186\189\182\255\232\233\230\ -\255\186\189\182\255\236\237\235\255\186\189\182\255\241\241\240\255\215\216\212\ -\255\227\229\226\255\186\189\182\255\232\233\230\255\185\188\181\255\221\222\218\ -\255\228\229\226\255\186\189\182\255\232\233\230\255\186\189\182\255\204\206\201\ -\255\236\237\235\255\141\143\138\216\136\138\133\092\170\172\167\245\252\252\251\ -\255\254\254\254\255\142\253\253\253\255\002\254\254\254\255\255\255\255\255\132\ -\253\253\253\255\002\255\255\255\255\254\254\254\255\131\253\253\253\255\006\255\ -\255\255\255\236\236\234\255\139\141\136\243\136\138\133\015\141\143\138\202\136\ -\138\133\253\131\136\138\133\255\131\136\138\133\254\132\136\138\133\253\133\137\ -\139\134\252\131\137\139\134\251\134\138\140\135\250\001\138\140\135\249\130\139\ -\141\136\249\002\141\143\138\230\137\139\134\083" - -let pixbuf () : GdkPixbuf.pixbuf = Marshal.from_string pixbuf_data 0 -;; -icon_32x32_devices_computer_png := Some (pixbuf ()) ;; - -let pixbuf_data = "\ -\132\149\166\190\000\000\005\123\000\000\000\001\000\000\000\003\000\000\000\003\ -\018\071\100\107\080\105\120\098\117\102\047\050\046\048\047\000\000\000\005\103\ -\071\100\107\080\000\000\005\103\002\001\000\002\000\000\000\096\000\000\000\024\ -\000\000\000\024\154\000\000\000\000\002\131\131\134\116\128\128\131\253\144\128\ -\128\131\255\002\128\128\131\253\131\131\134\116\132\000\000\000\000\002\128\128\ -\131\253\250\250\250\255\144\255\255\255\255\002\250\250\250\255\128\128\131\253\ -\132\000\000\000\000\003\128\128\131\255\252\252\253\255\048\087\143\255\142\032\ -\074\135\255\003\050\088\144\255\255\255\255\255\128\128\131\255\132\000\000\000\ -\000\009\128\128\131\255\248\249\251\255\034\075\135\255\090\129\181\255\093\132\ -\182\255\097\135\184\255\101\138\186\255\105\141\187\255\109\144\189\255\136\113\ -\147\191\255\003\032\074\135\255\255\255\255\255\128\128\131\255\132\000\000\000\ -\000\020\128\128\131\255\248\249\251\255\034\075\135\255\086\126\179\255\089\129\ -\180\255\094\133\183\255\100\137\185\255\105\142\188\255\108\145\190\255\113\148\ -\192\255\117\151\194\255\118\151\194\255\117\151\194\255\116\150\193\255\116\149\ -\192\255\114\148\192\255\113\147\191\255\032\074\135\255\255\255\255\255\128\128\ -\131\255\132\000\000\000\000\011\128\128\131\255\248\249\251\255\034\075\135\255\ -\084\125\178\255\090\131\182\255\096\135\185\255\102\140\188\255\106\144\191\255\ -\111\147\193\255\115\151\194\255\119\153\196\255\130\123\156\198\255\007\122\155\ -\197\255\120\154\196\255\119\153\195\255\117\151\194\255\032\074\135\255\255\255\ -\255\255\128\128\131\255\132\000\000\000\000\020\128\128\131\255\248\249\251\255\ -\034\076\135\255\086\128\181\255\092\133\184\255\098\138\188\255\104\143\190\255\ -\108\147\193\255\113\150\195\255\118\153\197\255\121\156\199\255\125\159\200\255\ -\117\153\197\255\102\142\190\255\091\134\185\255\081\125\180\255\069\116\174\255\ -\032\074\135\255\255\255\255\255\128\128\131\255\132\000\000\000\000\020\128\128\ -\131\255\248\249\251\255\034\076\136\255\086\129\183\255\094\136\186\255\100\141\ -\190\255\105\145\192\255\110\150\195\255\115\153\198\255\119\156\200\255\114\153\ -\197\255\094\138\190\255\081\128\184\255\079\127\183\255\077\124\181\255\074\122\ -\179\255\071\119\177\255\032\074\135\255\255\255\255\255\128\128\131\255\132\000\ -\000\000\000\020\128\128\131\255\248\249\251\255\034\076\136\255\087\131\184\255\ -\094\137\188\255\101\142\191\255\107\147\195\255\113\152\198\255\111\151\197\255\ -\098\143\193\255\091\137\191\255\090\137\190\255\089\135\189\255\086\133\188\255\ -\083\130\186\255\080\127\183\255\076\124\181\255\032\074\135\255\255\255\255\255\ -\128\128\131\255\132\000\000\000\000\020\128\128\131\255\248\249\251\255\034\076\ -\136\255\086\130\184\255\091\136\188\255\095\139\191\255\098\142\192\255\097\142\ -\193\255\096\142\194\255\098\144\195\255\098\144\196\255\098\144\195\255\095\142\ -\194\255\092\139\192\255\089\135\189\255\085\131\186\255\080\127\183\255\032\074\ -\135\255\255\255\255\255\128\128\131\255\132\000\000\000\000\020\128\128\131\255\ -\248\249\251\255\034\076\136\255\078\126\182\255\083\130\185\255\088\135\189\255\ -\093\139\192\255\097\143\195\255\101\147\198\255\105\150\200\255\106\152\201\255\ -\105\150\200\255\101\147\198\255\097\143\195\255\092\139\192\255\088\134\189\255\ -\083\130\185\255\032\074\135\255\255\255\255\255\128\128\131\255\132\000\000\000\ -\000\003\128\128\131\255\252\252\253\255\048\088\143\255\142\032\074\135\255\003\ -\050\089\145\255\255\255\255\255\128\128\131\255\132\000\000\000\000\002\128\128\ -\131\255\255\255\255\255\144\228\228\225\255\002\255\255\255\255\128\128\131\255\ -\132\000\000\000\000\002\128\128\131\253\250\250\250\255\144\255\255\255\255\002\ -\250\250\250\255\128\128\131\253\132\000\000\000\000\002\131\131\134\116\128\128\ -\131\253\144\128\128\131\255\002\128\128\131\253\131\131\134\116\138\000\000\000\ -\000\008\134\136\131\255\141\144\138\255\147\150\144\255\153\156\150\255\159\162\ -\156\255\165\168\162\255\171\174\167\255\134\136\131\255\137\000\000\000\000\022\ -\131\132\132\003\137\138\137\223\139\140\139\241\179\181\175\254\181\184\177\255\ -\184\187\180\255\181\184\177\255\184\187\180\255\181\184\177\255\184\187\180\255\ -\181\184\177\255\184\187\180\255\181\184\177\255\184\187\180\255\181\184\177\255\ -\184\187\180\255\181\184\177\255\184\187\180\255\179\181\175\254\139\140\139\241\ -\136\137\137\224\131\132\132\004\130\000\000\000\000\022\126\127\127\054\152\153\ -\153\236\221\222\219\255\186\189\181\255\187\190\183\255\191\197\186\255\198\201\ -\194\255\191\197\186\255\211\213\208\255\191\197\186\255\221\223\218\255\191\197\ -\186\255\220\223\218\255\191\197\186\255\211\213\208\255\191\197\186\255\198\200\ -\194\255\191\197\186\255\186\189\181\255\221\222\219\255\153\154\153\237\126\127\ -\127\058\130\000\000\000\000\003\124\125\126\122\183\183\183\251\219\220\217\255\ -\130\181\184\177\255\003\188\191\185\255\181\184\177\255\202\204\198\255\135\181\ -\184\177\255\007\202\204\198\255\181\184\177\255\188\191\184\255\181\184\177\255\ -\219\220\217\255\184\185\184\252\124\125\126\129\130\000\000\000\000\002\126\126\ -\127\200\248\248\248\255\146\255\255\255\255\002\248\248\248\255\125\125\127\208\ -\130\000\000\000\000\004\119\119\121\203\117\117\120\240\118\118\120\240\117\117\ -\120\240\130\117\117\120\241\001\117\117\119\242\130\116\116\119\242\132\116\116\ -\119\243\131\116\116\118\243\006\116\116\118\244\116\116\118\243\115\115\118\244\ -\116\116\118\244\115\115\118\244\118\118\120\210\131\000\000\000\000\020\000\000\ -\000\002\000\000\000\009\000\000\000\017\000\000\000\022\000\000\000\028\000\000\ -\000\034\000\000\000\040\000\000\000\047\000\000\000\053\000\000\000\059\000\000\ -\000\060\000\000\000\056\000\000\000\051\000\000\000\045\000\000\000\038\000\000\ -\000\032\000\000\000\026\000\000\000\021\000\000\000\012\000\000\000\003\154\000\ -\000\000\000" - -let pixbuf () : GdkPixbuf.pixbuf = Marshal.from_string pixbuf_data 0 -;; -icon_24x24_devices_computer_png := Some (pixbuf ()) ;; - -let pixbuf_data = "\ -\132\149\166\190\000\000\002\203\000\000\000\001\000\000\000\003\000\000\000\003\ -\018\071\100\107\080\105\120\098\117\102\047\050\046\048\047\000\000\000\002\183\ -\071\100\107\080\000\000\002\183\002\001\000\002\000\000\000\064\000\000\000\016\ -\000\000\000\016\003\000\000\000\000\129\129\132\172\128\128\131\253\138\128\128\ -\131\255\002\128\128\131\253\129\129\132\172\130\000\000\000\000\002\128\128\131\ -\253\242\242\242\255\138\255\255\255\255\002\242\242\242\255\128\128\131\253\130\ -\000\000\000\000\002\128\128\131\255\255\255\255\255\138\032\074\135\255\002\255\ -\255\255\255\128\128\131\255\130\000\000\000\000\004\128\128\131\255\255\255\255\ -\255\032\074\135\255\112\146\191\255\130\113\147\191\255\003\113\148\191\255\113\ -\148\192\255\113\148\191\255\130\113\147\191\255\003\032\074\135\255\255\255\255\ -\255\128\128\131\255\130\000\000\000\000\014\128\128\131\255\255\255\255\255\032\ -\074\135\255\106\143\189\255\111\147\191\255\115\151\194\255\119\154\196\255\122\ -\155\197\255\121\155\197\255\117\152\195\255\106\143\189\255\032\074\135\255\255\ -\255\255\255\128\128\131\255\130\000\000\000\000\014\128\128\131\255\255\255\255\ -\255\032\074\135\255\105\142\189\255\111\148\193\255\116\153\197\255\120\155\198\ -\255\106\145\193\255\084\129\183\255\073\121\179\255\069\117\176\255\032\074\135\ -\255\255\255\255\255\128\128\131\255\130\000\000\000\000\014\128\128\131\255\255\ -\255\255\255\032\074\135\255\101\141\190\255\103\144\192\255\103\145\193\255\091\ -\137\189\255\089\135\189\255\087\134\188\255\084\131\186\255\078\126\182\255\032\ -\074\135\255\255\255\255\255\128\128\131\255\130\000\000\000\000\014\128\128\131\ -\255\255\255\255\255\032\074\135\255\078\125\182\255\086\132\187\255\092\139\192\ -\255\098\144\196\255\100\146\197\255\098\144\196\255\092\139\192\255\086\132\187\ -\255\032\074\135\255\255\255\255\255\128\128\131\255\130\000\000\000\000\002\128\ -\128\131\255\255\255\255\255\138\032\074\135\255\002\255\255\255\255\128\128\131\ -\255\130\000\000\000\000\002\128\128\131\253\241\241\241\255\138\255\255\255\255\ -\002\241\241\241\255\128\128\131\253\130\000\000\000\000\002\129\129\132\172\128\ -\128\131\253\138\128\128\131\255\002\128\128\131\253\129\129\132\172\134\000\000\ -\000\000\002\134\136\131\255\201\206\196\255\130\165\174\157\255\002\201\206\196\ -\255\134\136\131\255\133\000\000\000\000\034\136\138\133\004\136\138\133\116\169\ -\172\166\255\205\208\201\255\186\189\182\255\205\208\201\255\186\189\182\255\205\ -\208\201\255\186\189\182\255\205\208\201\255\186\189\182\255\205\208\201\255\186\ -\189\182\255\155\158\152\255\136\138\133\119\136\138\133\009\136\138\133\105\136\ -\138\133\255\196\198\192\255\186\189\182\255\204\207\200\255\186\189\182\255\192\ -\195\189\255\186\189\182\255\190\193\186\255\186\189\182\255\193\196\189\255\186\ -\189\182\255\206\209\202\255\196\198\192\255\136\138\133\255\136\138\133\115\136\ -\138\133\255\213\213\211\255\140\255\255\255\255\003\213\213\211\255\136\138\133\ -\255\142\143\139\214\142\136\138\133\255\001\142\143\139\214" - -let pixbuf () : GdkPixbuf.pixbuf = Marshal.from_string pixbuf_data 0 -;; -icon_16x16_devices_computer_png := Some (pixbuf ()) ;; diff --git a/virt-ctrl/vc_mainwindow.ml b/virt-ctrl/vc_mainwindow.ml deleted file mode 100644 index c34a803..0000000 --- a/virt-ctrl/vc_mainwindow.ml +++ /dev/null @@ -1,202 +0,0 @@ -(* 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 -open Virt_ctrl_gettext.Gettext - -let title = s_ "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 - (sprintf (f_ "Virtualization control tool (virt-ctrl) by -Richard W.M. Jones (rjones@redhat.com). - -Copyright %s 2007-2008 Red Hat Inc. - -Libvirt version: %s - -Gtk toolkit version: %s") utf8_copyright virt_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 -> - s_ "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 = s_ "Error" in - let icon = GMisc.image () in - icon#set_stock `DIALOG_ERROR; - icon#set_icon_size `DIALOG; - GToolbox.message_box ~title ~icon label - -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 quit_item = - 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 (s_ "File") in - let help_menu = factory#add_submenu (s_ "Help") in - - window#add_accel_group accel_group; - - (* File menu. *) - let factory = new GMenu.factory file_menu ~accel_group in - let open_item = factory#add_item (s_ "Open connection ...") - ~key:GdkKeysyms._O in - ignore (factory#add_separator ()); - let quit_item = factory#add_item (s_ "Quit") ~key:GdkKeysyms._Q in - - ignore (open_item#connect#activate - ~callback:(Vc_connection_dlg.open_connection window)); - - (* Help menu. *) - let factory = new GMenu.factory help_menu ~accel_group in - let help_item = factory#add_item (s_ "Help") in - let help_about_item = factory#add_item (s_ "About ...") in - - ignore (help_about_item#connect#activate ~callback:help_about); - - quit_item in - - (* The toolbar. *) - let toolbar = GButton.toolbar ~packing:vbox#pack () in - - (* The treeview. *) - let (tree, model, columns, initial_state) = - Vc_connections.make_treeview - ~packing:(vbox#pack ~expand:true ~fill:true) () in - - (* Add buttons to the toolbar (requires the treeview to - * have been made above). - *) - let () = - let connect_button_menu = GMenu.menu () in - let connect_button = - GButton.menu_tool_button - ~label:(s_ "Connect ...") ~stock:`CONNECT - ~menu:connect_button_menu - ~packing:toolbar#insert () in - ignore (GButton.separator_tool_item ~packing:toolbar#insert ()); - let open_button = - GButton.tool_button ~label:(s_ "Details") ~stock:`OPEN - ~packing:toolbar#insert () in - ignore (GButton.separator_tool_item ~packing:toolbar#insert ()); - let start_button = - GButton.tool_button ~label:(s_ "Start") ~stock:`ADD - ~packing:toolbar#insert () in - let pause_button = - GButton.tool_button ~label:(s_ "Pause") ~stock:`MEDIA_PAUSE - ~packing:toolbar#insert () in - let resume_button = - GButton.tool_button ~label:(s_ "Resume") ~stock:`MEDIA_PLAY - ~packing:toolbar#insert () in - ignore (GButton.separator_tool_item ~packing:toolbar#insert ()); - let shutdown_button = - GButton.tool_button ~label:(s_ "Shutdown") ~stock:`STOP - ~packing:toolbar#insert () in - - (* Set callbacks for the toolbar buttons. *) - ignore (connect_button#connect#clicked - ~callback:(Vc_connection_dlg.open_connection window)); - 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)); - - (* Set a menu on the connect menu-button. *) - let () = - let factory = new GMenu.factory connect_button_menu (*~accel_group*) in - let local_xen = factory#add_item (s_ "Local Xen") in - let local_qemu = factory#add_item (s_ "Local QEMU/KVM") in - ignore (factory#add_separator ()); - let open_dialog = factory#add_item (s_ "Connect to ...") in - ignore (local_xen#connect#activate - ~callback:Vc_connection_dlg.open_local_xen); - ignore (local_qemu#connect#activate - ~callback:Vc_connection_dlg.open_local_qemu); - ignore (open_dialog#connect#activate - ~callback:(Vc_connection_dlg.open_connection window)) in - () in - - (* 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.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 ()); ())); - - (* Display the window. *) - window#show () diff --git a/virt-ctrl/vc_mainwindow.mli b/virt-ctrl/vc_mainwindow.mli deleted file mode 100644 index 39439e9..0000000 --- a/virt-ctrl/vc_mainwindow.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* 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. - - Make the main window. -*) - -(** This function creates the main window. You have to pass in - callback functions to wire everything up. -*) -val make : - start_domain:Vc_domain_ops.dops_callback_fn -> - pause_domain:Vc_domain_ops.dops_callback_fn -> - resume_domain:Vc_domain_ops.dops_callback_fn -> - shutdown_domain:Vc_domain_ops.dops_callback_fn -> - open_domain_details:Vc_domain_ops.dops_callback_fn -> - unit diff --git a/virt-ctrl/virt_ctrl.ml b/virt-ctrl/virt_ctrl.ml deleted file mode 100644 index 9e5053e..0000000 --- a/virt-ctrl/virt_ctrl.ml +++ /dev/null @@ -1,36 +0,0 @@ -(* 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 -open Virt_ctrl_gettext.Gettext - -let () = - (* Build the main window and wire up the buttons to the callback functions *) - Vc_mainwindow.make - ~start_domain:Vc_domain_ops.start_domain - ~pause_domain:Vc_domain_ops.pause_domain - ~resume_domain:Vc_domain_ops.resume_domain - ~shutdown_domain:Vc_domain_ops.shutdown_domain - ~open_domain_details:Vc_domain_ops.open_domain_details; - - (* Enter the Gtk main loop. *) - GMain.main (); - - (* Useful to catch memory bugs in the ocaml libvirt bindings. *) - Gc.compact () -- cgit