summaryrefslogtreecommitdiffstats
path: root/virt-ctrl
diff options
context:
space:
mode:
Diffstat (limited to 'virt-ctrl')
-rw-r--r--virt-ctrl/Makefile.in136
-rwxr-xr-xvirt-ctrl/mingw-gcc-wrapper.ml70
-rwxr-xr-xvirt-ctrl/rebuild-icons.sh44
-rw-r--r--virt-ctrl/vc_connection_dlg.ml203
-rw-r--r--virt-ctrl/vc_connection_dlg.mli43
-rw-r--r--virt-ctrl/vc_connections.ml477
-rw-r--r--virt-ctrl/vc_connections.mli102
-rw-r--r--virt-ctrl/vc_dbus.ml317
-rw-r--r--virt-ctrl/vc_dbus.mli22
-rw-r--r--virt-ctrl/vc_domain_ops.ml109
-rw-r--r--virt-ctrl/vc_domain_ops.mli35
-rw-r--r--virt-ctrl/vc_helpers.ml97
-rw-r--r--virt-ctrl/vc_helpers.mli51
-rw-r--r--virt-ctrl/vc_icons.ml270
-rw-r--r--virt-ctrl/vc_mainwindow.ml202
-rw-r--r--virt-ctrl/vc_mainwindow.mli31
-rw-r--r--virt-ctrl/virt_ctrl.ml36
17 files changed, 0 insertions, 2245 deletions
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 ()
generated by cgit (git 2.34.1) at 2024-04-19 23:46:37 +0000