cmdline.cmi:
-cmdline.cmo: utils.cmi cmdline.cmi
-cmdline.cmx: utils.cmx cmdline.cmi
+cmdline.cmo: utils.cmi config.cmi cmdline.cmi
+cmdline.cmx: utils.cmx config.cmx cmdline.cmi
config.cmi:
config.cmo: config.cmi
config.cmx: config.cmi
doc/
guestfs-browser-*.tar.gz
guestfs-browser
+guestfs-browser.1
guestfs-browser.spec
+html/*.html
install-sh
missing
+pod2htm?.tmp
stamp-h1
-This document describes the software architecture of the Guestfs
-Browser, useful if you want to hack on it.
+This document describes the software architecture of the
+guestfs-browser, useful if you want to hack on it.
About OCaml
-----------
First of all about OCaml: Read the tutorial and other resources
available from this site:
+ http://caml.inria.fr/
http://ocaml-tutorial.org/
If you are using emacs, install tuareg-mode instead of using the
Because libvirt and libguestfs API calls are usually long-running, we
have to use threads, making these API calls in one thread, while
-another thread keeps the display updated. In Guestfs Browser we use
+another thread keeps the display updated. In guestfs-browser we use
two threads, and send messages between them. The main thread keeps
the display updated and runs the glib main loop. The slave thread
issues libvirt and libguestfs API calls serially. There is a FIFO
$(SOURCES) \
HACKING \
Throbber.png Throbber.gif \
- .gitignore guestfs-browser.spec
+ .gitignore guestfs-browser.spec \
+ guestfs-browser.pod \
+ guestfs-browser.1 \
+ html/pod.css
CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser
.ml.cmx:
$(OCAMLFIND) ocamlopt $(OCAMLCFLAGS) -c $< -o $@
+# Man page.
+man_MANS = guestfs-browser.1
+
+if HAVE_PERLDOC
+
+guestfs-browser.1: guestfs-browser.pod
+ pod2man \
+ --section 1 \
+ -c "Virtualization Support" \
+ --release "$(PACKAGE_NAME)-$(PACKAGE_VERSION)" \
+ $< > $@
+
+noinst_DATA = \
+ html/guestfs-browser.1.html
+
+html/guestfs-browser.1.html: guestfs-browser.pod
+ mkdir -p html
+ pod2html \
+ --css 'pod.css' \
+ --htmldir html \
+ --outfile html/guestfs-browser.1.html \
+ guestfs-browser.pod
+
+endif
+
+# Maintainer website update.
+HTMLFILES = \
+ html/guestfs-browser.1.html
+
+WEBSITEDIR = $(HOME)/d/redhat/websites/libguestfs
+
+website: $(HTMLFILES)
+ cp $(HTMLFILES) $(WEBSITEDIR)
+
+CLEANFILES += $(HTMLFILES) pod2*.tmp
+
# Convert internal documentation to HTML.
docs:
rm -rf doc
->>> This is alpha quality software. Read 'HACKING' and 'TODO'. <<<
-
Guest filesystem browser
Copyright (C) 2010 Red Hat Inc.
autoreconf -i # if using the git version
./configure
make
-
-We strongly suggest you run the program like this:
-
- guestfs-browser [--verbose] --connect qemu:///system
-or:
- guestfs-browser [--verbose] disk.img
-
---verbose enables debug level messages and is recommended.
-
---connect tells the program which libvirt URI to connect to.
-
-Note that libguestfs cannot access remote storage, so accessing a
-remote libvirt URI will usually not work.
| Open_guest of string
| Open_images of (string * string option) list
+let display_version () =
+ printf "%s %s\n" Config.package Config.version;
+ exit 0
+
let format = ref None
let images = ref []
let guests = ref []
"--format", Arg.String set_format, "format Set format";
"-v", Arg.Unit set_verbose_flag, " Enable debugging messages";
"--verbose", Arg.Unit set_verbose_flag, " Enable debugging messages";
- "-V", Arg.Unit set_verbose_flag, " Display version and exit";
- "--version", Arg.Unit set_verbose_flag, " Display version and exit";
+ "-V", Arg.Unit display_version, " Display version and exit";
+ "--version", Arg.Unit display_version, " Display version and exit";
"-x", Arg.Unit set_trace_flag, " Enable tracing of libguestfs calls";
]
dnl Check for gdk_pixbuf_mlsource program.
AC_PATH_PROGS([GDK_PIXBUF_MLSOURCE], [gdk_pixbuf_mlsource])
+dnl Optional programs.
+AC_CHECK_PROG(PERLDOC,[perldoc],[perldoc],[no])
+if test "x$PERLDOC" = "xno" ; then
+ AC_MSG_WARN([perldoc not found - install perl to make man pages])
+fi
+AM_CONDITIONAL(HAVE_PERLDOC,[test "$perldoc" != "no"])
+
AC_CONFIG_HEADERS([config.h])
AC_CONFIG_FILES([Makefile config.ml guestfs-browser.spec])
AC_OUTPUT
type t = Filetree_type.t
-let rec create ?status ~packing () =
+let rec create ~packing () =
let view = GTree.view ~packing () in
(*view#set_rules_hint true;*)
(*view#selection#set_mode `MULTIPLE; -- add this later *)
index_col = index_col;
mode_col = mode_col; name_col = name_col; size_col = size_col;
date_col = date_col; link_col = link_col;
- status = status
} in
(* Open a context menu when a button is pressed. *)
let row = model#get_iter path in
let hdata = get_hdata t row in
match hdata with
- | _, (Loading | ErrorMessage _) -> None
+ | _, (Loading | ErrorMessage _ | Info _) -> None
| _, (Top _ | Directory _ | File _) -> Some (path, hdata)
) paths in
let item = factory#add_item "Directory information" in
item#misc#set_sensitive false;
let item = factory#add_item "Space used by directory" in
- item#misc#set_sensitive false;
+ ignore (item#connect#activate ~callback:(disk_usage t path));
ignore (factory#add_separator ());
let item = factory#add_item "Download ..." in
item#misc#set_sensitive false;
| _, File _ | IsLeaf, _ -> assert false
(* Node should not exist in the tree. *)
- | NodeNotStarted, (Loading | ErrorMessage _) -> assert false
+ | NodeNotStarted, (Loading | ErrorMessage _ | Info _) -> assert false
(* This is the callback when the slave has read the directory for us. *)
and when_read_directory ({ model = model } as t) path entries =
model#set ~row ~column:t.link_col (markup_of_link link)
) entries;
- (* Remove the placeholder entry. NB. Must be done AFTER adding
- * the other entries, or else Gtk will unexpand the row.
+ (* Remove the placeholder "Loading" entry. NB. Must be done AFTER
+ * adding the other entries, or else Gtk will unexpand the row.
*)
(try
- let placeholder = model#iter_children ~nth:0 (Some row) in
- ignore (model#remove placeholder)
- with Invalid_argument _ -> ()
+ let hdata = IsLeaf, Loading in
+ let row = find_child_node_by_hdata t row hdata in
+ ignore (model#remove row)
+ with Invalid_argument _ | Not_found -> ()
);
(* The original directory entry has now been loaded, so
| exn ->
(* unexpected exception: re-raise it *)
raise exn
-
-let set_status_fn t status =
- t.status <- Some status
(** A filetree widget. Actually an opaque object which contains the
widget and other data. Use the accessors below. *)
-val create : ?status:(string -> unit) -> packing:(GObj.widget -> unit) -> unit -> t
+val create : packing:(GObj.widget -> unit) -> unit -> t
(** Create a new filetree widget (empty).
- In the optional [?status] parameter you can pass in some
- function that updates a status bar. This function will be
- called by the filetree whenever the user should be told about
- some ordinary event having happened (for example, that a file is
- being downloaded or has finished downloading).
-
[~packing] is the required packing for the widget. *)
val clear : t -> unit
system and/or filesystems described by the [data] struct. The
[name] parameter should be some host-side (verifiable) name;
usually we pass the name of the guest from libvirt here. *)
-
-val set_status_fn : t -> (string -> unit) -> unit
- (** Set or update the [status] function. *)
dlg#destroy ();
(* Download the file. *)
- update_status t
- (sprintf "Downloading %s to %s ..." pathname localfile);
- Slave.download_file src pathname localfile
- (when_downloaded_file t pathname localfile)
-
-and when_downloaded_file t _ localfile () =
- update_status t (sprintf "Finished downloading %s" localfile)
+ Slave.download_file src pathname localfile Slave.no_callback
(* Download a directory as a tarball. *)
let rec download_dir_tarball ({ model = model } as t) format path () =
dlg#destroy ();
(* Download the directory. *)
- update_status t
- (sprintf "Downloading %s to %s ..." pathname localfile);
Slave.download_dir_tarball src pathname format localfile
- (when_downloaded_dir_tarball t pathname localfile)
-
-and when_downloaded_dir_tarball t _ localfile () =
- update_status t (sprintf "Finished downloading %s" localfile)
+ Slave.no_callback
let rec download_dir_find0 ({ model = model } as t) path () =
let row = model#get_iter path in
dlg#destroy ();
(* Download the directory. *)
- update_status t
- (sprintf "Downloading filenames in %s to %s ..." pathname localfile);
- Slave.download_dir_find0 src pathname localfile
- (when_downloaded_dir_find0 t pathname localfile)
+ Slave.download_dir_find0 src pathname localfile Slave.no_callback
+
+let has_child_node_equals t row hdata =
+ try ignore (find_child_node_by_hdata t row hdata); true
+ with Not_found -> false
+
+(* Calculate disk space used by a directory. *)
+let rec disk_usage ({ model = model } as t) path () =
+ t.view#expand_row path;
+
+ let row = model#get_iter path in
+ let src, pathname = get_pathname t row in
+ debug "disk_usage %s" pathname;
+
+ (* See if this node already has an Info "disk_usage" child node. If
+ * so they don't recreate it.
+ *)
+ let hdata = IsLeaf, Info "disk_usage" in
+ if not (has_child_node_equals t row hdata) then (
+ (* Create the child node first. *)
+ let row = model#insert ~parent:row 0 in
+ store_hdata t row hdata;
+ model#set ~row ~column:t.name_col "<i>Calculating disk usage ...</i>";
+
+ Slave.disk_usage src pathname (when_disk_usage t path)
+ )
+
+and when_disk_usage ({ model = model } as t) path kbytes =
+ let row = model#get_iter path in
-and when_downloaded_dir_find0 t _ localfile () =
- update_status t (sprintf "Finished downloading %s" localfile)
+ (* Find the Info "disk_usage" child node add above, and replace the
+ * text in it with the final size.
+ *)
+ try
+ let hdata = IsLeaf, Info "disk_usage" in
+ let row = find_child_node_by_hdata t row hdata in
+ let msg = sprintf "<b>Disk usage: %Ld KB</b>" kbytes in
+ model#set ~row ~column:t.name_col msg
+ with
+ Not_found -> ()
(**/**)
+val disk_usage : Filetree_type.t -> Gtk.tree_path -> unit -> unit
+
val download_file : Filetree_type.t -> Gtk.tree_path -> unit -> unit
val download_dir_tarball : Filetree_type.t -> Slave.download_dir_tarball_format -> Gtk.tree_path -> unit -> unit
size_col : int64 GTree.column;
date_col : string GTree.column;
link_col : string GTree.column;
- mutable status : (string -> unit) option;
}
and hdata = state_t * content_t
and content_t =
| Loading (* special "loading ..." node *)
| ErrorMessage of string (* error message node *)
+ | Info of string (* information node (eg. disk usage) *)
| Top of Slave.source (* top level OS or volume node *)
| Directory of Slave.direntry (* a directory *)
| File of Slave.direntry (* a file inc. special files *)
try Hashtbl.find hash index
with Not_found -> assert false
+(* Iterate over children of node, looking for matching hdata. *)
+let find_child_node_by_hdata ({ model = model } as t) row hdata =
+ let rec loop row =
+ if hdata = get_hdata t row then
+ row
+ else if model#iter_next row then
+ loop row
+ else
+ raise Not_found
+ in
+
+ if not (model#iter_has_child row) then
+ raise Not_found;
+
+ let first_child = model#iter_children (Some row) in
+ loop first_child
+
(* Search up to the top of the tree so we know if this directory
* comes from an OS or a volume, and the full path to here.
*
let parent = model#iter_parent row in
match hdata, parent with
- | (IsLeaf, Loading), Some parent ->
+ | (IsLeaf, (Loading|ErrorMessage _|Info _)), Some parent ->
get_pathname t parent
- | (IsLeaf, Loading), None ->
+ | (IsLeaf, (Loading|ErrorMessage _|Info _)), None ->
assert false
| (_, Directory { Slave.dent_name = name }), Some parent
| (_, File { Slave.dent_name = name }), Some parent ->
| (_, File _), None -> assert false
| (_, Loading), _ -> assert false
| (_, ErrorMessage _), _ -> assert false
-
-(* Update the status bar. *)
-let update_status { status = f } msg =
- match f with
- | None -> () (* user didn't give us a [status] function to call *)
- | Some f -> f msg
+ | (_, Info _), _ -> assert false
size_col : int64 GTree.column;
date_col : string GTree.column;
link_col : string GTree.column;
- mutable status : (string -> unit) option;
}
and hdata = state_t * content_t
and content_t =
| Loading
| ErrorMessage of string
+ | Info of string
| Top of Slave.source
| Directory of Slave.direntry
| File of Slave.direntry
val get_hdata : t -> Gtk.tree_iter -> hdata
(* Store/retrieve hdata structure in a model row. *)
+val find_child_node_by_hdata : t -> Gtk.tree_iter -> hdata -> Gtk.tree_iter
+ (* [find_child_node_by_hdata t row hdata] searches the direct children
+ of [row] looking for one which exactly matches [hdata] and returns
+ that child. If no child found, raises [Not_found]. *)
+
val get_pathname : t -> Gtk.tree_iter -> Slave.source * string
(* Get the full path to a row by chasing up through the tree to the
top. This also returns the source (eg. operating system or single
volume). *)
-
-val update_status : t -> string -> unit
- (* Update the status bar. *)
--- /dev/null
+=encoding utf8
+
+=head1 NAME
+
+guestfs-browser - Guest filesystem browser
+
+=head1 SYNOPSIS
+
+ guestfs-browser [--options]
+
+ guestfs-browser [--options] -d domname
+
+ guestfs-browser [--options] -a disk.img [-a disk.img [...]]
+
+=head1 DESCRIPTION
+
+The guest filesystem browser is a graphical program for browsing
+virtual machine filesystems and disk images interactively.
+
+If you need to make scripted changes or browse disk images from the
+command line, we suggest you look at L<guestfish(1)> or
+L<virt-rescue(1)> instead. If you want to mount a disk image or
+virtual machine disk on the host, use L<guestmount(1)>.
+
+To start guestfs-browser with an empty window, use:
+
+ guestfs-browser
+
+To start guestfs-browser pointing to a disk image file called
+C<disk.img>, use:
+
+ guestfs-browser -a disk.img
+
+To start guestfs-browser pointing to a libvirt domain called C<guest>,
+use:
+
+ guestfs-browser [-c libvirtURI] -d guest
+
+Note that this only works for local libvirt guests (at least the
+browser must be able to read the disks locally).
+
+The program does not need to be run as root, unless root is required
+in order to access the disk images. Currently guestfs-browser only
+accesses the disk image read only. It is therefore safe to use
+guestfs-browser on live virtual machines, but you may see strange or
+inconsistent results.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-a>
+
+=item B<--add>
+
+Add I<file> which should be a disk image. You can supply multiple
+disk images by repeating this option.
+
+The format of the disk image is auto-detected. To override this and
+force a particular format use the I<--format=..> option.
+
+=item B<-c> URI
+
+=item B<--connect> URI
+
+If using libvirt, connect to the given I<URI>. If omitted, then we
+connect to the default libvirt hypervisor.
+
+If you specify guest block devices directly (I<-a>), then libvirt is
+not used at all.
+
+=item B<-d> guest
+
+=item B<--domain> guest
+
+Add all the disks from the named libvirt guest.
+
+=item B<--format raw|qcow2|..>
+
+=item B<--format "">
+
+The default for the I<-a> option is to auto-detect the format of the
+disk image. Using this forces the disk format for I<-a> options which
+follow on the command line. Using I<--format> with no argument
+switches back to auto-detection for subsequent I<-a> options.
+
+For example:
+
+ guestfs-browser --format raw -a disk.img
+
+forces raw format (no auto-detection) for C<disk.img>.
+
+ guestfs-browser --format raw -a disk.img --format "" -a another.img
+
+forces raw format (no auto-detection) for C<disk.img> and reverts to
+auto-detection for C<another.img>.
+
+If you have untrusted raw-format guest disk images, you should use
+this option to specify the disk format. This avoids a possible
+security problem with malicious guests (CVE-2010-3851).
+
+=item B<-v>
+
+=item B<--verbose>
+
+Enable verbose messages for debugging.
+
+=item B<-V>
+
+=item B<--version>
+
+Display version number and exit.
+
+=item B<-x>
+
+Enable tracing of libguestfs API calls.
+
+=back
+
+=head1 SEE ALSO
+
+L<guestfs(3)>,
+L<guestfish(1)>,
+L<virt-cat(1)>,
+L<virt-edit(1)>,
+L<virt-rescue(1)>,
+L<http://people.redhat.com/~rjones/guestfs-browser/>,
+L<http://libguestfs.org/>.
+
+=head1 AUTHOR
+
+Richard W.M. Jones L<http://people.redhat.com/~rjones/>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2010 Red Hat Inc.
+
+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.
BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)
+BuildRequires: libguestfs-devel >= 1.7.9
+BuildRequires: libvirt-devel
BuildRequires: ocaml
-BuildRequires: ocaml-ocamldoc
BuildRequires: ocaml-findlib-devel
BuildRequires: ocaml-libvirt-devel
BuildRequires: ocaml-libguestfs-devel
BuildRequires: ocaml-xml-light-devel
BuildRequires: ocaml-extlib-devel
BuildRequires: ocaml-lablgtk-devel
+BuildRequires: /usr/bin/pod2man
+BuildRequires: /usr/bin/pod2html
+
+Requires: libguestfs >= 1.7.9
+
+# Only needed to build the internal documentation.
+#BuildRequires: ocaml-ocamldoc
%description
%build
%configure
make %{?_smp_mflags}
-make docs
%install
%files
%defattr(-,root,root,-)
%doc COPYING HACKING README
-%doc doc
%{_bindir}/guestfs-browser
+%{_mandir}/man1/guestfs-browser.1*
%changelog
-* Fri Jul 9 2010 Richard W.M. Jones <rjones@redhat.com> - @VERSION@-1
+* Tue Dec 14 2010 Richard W.M. Jones <rjones@redhat.com> - @VERSION@-1
- Initial RPM release.
--- /dev/null
+/* CSS to make pod2html files look a little bit better. */
+
+body {
+ margin-left: 4em;
+}
+
+body p, body ul, ol, body dl {
+ margin-left: 2em;
+ width: 31em;
+}
+
+pre {
+ width: 31em;
+}
+
+li {
+ padding-bottom: 0.5em;
+}
+
+/* Code sections. */
+
+pre {
+ background-color: #f8f8f8;
+ color: rgb(204,0,0);
+ font-weight: 550;
+ border-left: 6px solid rgb(204,64,64);
+ padding: 6px;
+ margin-left: 1em;
+ font-size: 120%;
+}
+
+/* Bold, italic in man pages. */
+b, strong {
+ color: rgb(204,0,0);
+}
+
+i, em {
+ color: rgb(204,0,0);
+}
+
+/* Name heading. */
+
+body > h1:first-of-type {
+ display: none;
+}
+
+body > h1:first-of-type + p {
+ font-size: 125%;
+ font-weight: bold;
+ color: rgb(204,0,0);
+ margin-left: -32px;
+}
+
+/* Warning heading in man pages. */
+a[name="warning"] {
+ -moz-border-radius-topleft: 5px;
+ -moz-border-radius-topright: 5px;
+ border-radius-topleft: 5px;
+ border-radius-topright: 5px;
+
+ color: white;
+ background-color: rgb(204,0,0);
+}
+a[name="warning"]:before {
+ content: "\00a0\00a0\00a0";
+}
+a[name="warning"]:after {
+ content: "\00a0\00a0\00a0";
+}
+
+/* Put the index on the right hand side in a floating box. */
+div[name="index"] {
+ float: right;
+ width: 18em;
+ border-left: 3em solid white;
+ background-color: #fcfcfc;
+ margin-top: 32px;
+ padding-top: 0px;
+ margin-left: 1em;
+ padding-left: 1em;
+ padding-right: 1em;
+ font-size: 90%;
+}
+
+div[name="index"] a[href] {
+ text-decoration: none;
+}
+
+div[name="index"] a[href]:hover {
+ text-decoration: underline;
+}
+
+div[name="index"] a[href]:before {
+ content: '#\00a0';
+ color: rgb(204,0,0);
+ font-size: x-small;
+}
+
+div[name="index"] > ul {
+ width: 17em;
+ list-style: none;
+ margin-left: 0px;
+ margin-right: 0px;
+ padding-left: 0px;
+ padding-right: 0px;
+}
+
+div[name="index"] > ul > li {
+ margin-bottom: 0.5em;
+}
+
+div[name="index"] > ul ul {
+ width: 16em;
+ list-style: none;
+ margin-left: 0px;
+ margin-right: 0px;
+ padding-left: 0px;
+ padding-right: 0px;
+ margin-bottom: 0.5em;
+}
+
+div[name="index"] > ul > ul li {
+ display: inline;
+ margin-right: 1em;
+}
+
+/*
+div[name="index"] > ul > ul li:after {
+ color: #ccc;
+ content: '\2014';
+}
+*/
+
+/* Get rid of those horrible <hr>'s :-( */
+hr { display: none; }
+
+/* Demote <h1>'s and set rest of headers relative. */
+h1 {
+ font-size: 100%;
+ color: black;
+ border-bottom: solid 1px rgb(204,0,0);
+}
+
+h2 {
+ font-size: 95%;
+ border-bottom: none;
+}
+
+h3 {
+ font-size: 90%;
+}
+
+h4 {
+ font-size: 85%;
+}
Slave.set_failure_hook (Window.failure ws);
Slave.set_busy_hook (Window.throbber_busy ws);
Slave.set_idle_hook (Window.throbber_idle ws);
+ Slave.set_status_hook (Window.set_statusbar ws);
Slave.set_progress_hook (Window.progress ws);
(* What did the user request on the command line? *)
type command =
| Exit_thread
| Connect of string option * domain list callback
+ | Disk_usage of source * string * int64 callback
| Download_dir_find0 of source * string * string * unit callback
| Download_dir_tarball of source * string * download_dir_tarball_format * string * unit callback
| Download_file of source * string * string * unit callback
| Exit_thread -> "Exit_thread"
| Connect (Some name, _) -> sprintf "Connect %s" name
| Connect (None, _) -> "Connect NULL"
+ | Disk_usage (src, remotedir, _) ->
+ sprintf "Disk_usage (%s, %s)" (string_of_source src) remotedir
| Download_dir_find0 (src, remotedir, localfile, _) ->
sprintf "Download_dir_find0 (%s, %s, %s)"
(string_of_source src) remotedir localfile
let failure_hook = ref (fun _ -> ())
let busy_hook = ref (fun _ -> ())
let idle_hook = ref (fun _ -> ())
+let status_hook = ref (fun _ -> ())
let progress_hook = ref (fun _ -> ())
let set_failure_hook cb = failure_hook := cb
let set_busy_hook cb = busy_hook := cb
let set_idle_hook cb = idle_hook := cb
+let set_status_hook cb = status_hook := cb
let set_progress_hook cb = progress_hook := cb
(* Execute a function, while holding a mutex. If the function
)
let connect ?fail uri cb = send_to_slave ?fail (Connect (uri, cb))
+let disk_usage ?fail src remotedir cb =
+ send_to_slave ?fail (Disk_usage (src, remotedir, cb))
let download_dir_find0 ?fail src remotedir localfile cb =
send_to_slave ?fail (Download_dir_find0 (src, remotedir, localfile, cb))
let download_dir_tarball ?fail src remotedir format localfile cb =
f ()
) ()
+(* Update the status bar. *)
+let status fs =
+ let f str = GtkThread.async !status_hook str in
+ ksprintf f fs
+
let rec loop () =
debug "top of slave loop";
close_all ()
| Connect (name, cb) ->
+ let printable_name =
+ match name with None -> "default hypervisor" | Some uri -> uri in
+ status "Connecting to %s ..." printable_name;
+
close_all ();
conn := Some (C.connect_readonly ?name ());
) doms in
let cmp { dom_name = n1 } { dom_name = n2 } = compare n1 n2 in
let doms = List.sort ~cmp doms in
+
+ status "Connected to %s" printable_name;
callback_if_not_discarded cb doms
+ | Disk_usage (src, remotedir, cb) ->
+ status "Calculating disk usage of %s ..." remotedir;
+
+ let g = get_g () in
+ let r =
+ with_mount_ro g src (
+ fun () ->
+ g#du remotedir
+ ) in
+
+ status "Finished calculating disk usage of %s" remotedir;
+ callback_if_not_discarded cb r
+
| Download_dir_find0 (src, remotedir, localfile, cb) ->
+ status "Downloading %s filenames to %s ..." remotedir localfile;
+
let g = get_g () in
with_mount_ro g src (
fun () ->
g#find0 remotedir localfile
);
+
+ status "Finished downloading %s" localfile;
callback_if_not_discarded cb ()
| Download_dir_tarball (src, remotedir, format, localfile, cb) ->
+ status "Downloading %s to %s ..." remotedir localfile;
+
let g = get_g () in
let f = match format with
| Tar -> g#tar_out
fun () ->
f remotedir localfile
);
+
+ status "Finished downloading %s" localfile;
callback_if_not_discarded cb ()
| Download_file (src, remotefile, localfile, cb) ->
+ status "Downloading %s to %s ..." remotefile localfile;
+
let g = get_g () in
with_mount_ro g src (
fun () ->
g#download remotefile localfile
);
+
+ status "Finished downloading %s" localfile;
callback_if_not_discarded cb ()
| Open_domain (name, cb) ->
+ status "Opening %s ..." name;
+
let conn = get_conn () in
let dom = D.lookup_by_name conn name in
let xml = D.get_xml_desc dom in
open_disk_images images cb
| Open_images (images, cb) ->
+ status "Opening disk images ...";
+
open_disk_images images cb
| Read_directory (src, dir, cb) ->
+ status "Reading directory %s ..." dir;
+
let g = get_g () in
let names, stats, links =
with_mount_ro g src (
fun ((name, stat), link) ->
{ dent_name = name; dent_stat = stat; dent_link = link }
) entries in
+
+ status "Finished reading directory %s" dir;
callback_if_not_discarded cb entries
(* Expect to be connected, and return the current libvirt connection. *)
g#launch ();
+ status "Listing filesystems ...";
+
(* Get list of filesystems. *)
let fses = g#list_filesystems () in
+ status "Looking for operating systems ...";
+
(* Perform inspection. This can fail, ignore errors. *)
let roots =
try Array.to_list (g#inspect_os ())
insp_all_filesystems = fses;
insp_oses = oses;
} in
+
+ status "Finished opening disk";
callback_if_not_discarded cb data
(* guestfs_lstatlist has a "hidden" limit of the protocol message size.
file (a ASCII NUL-separated text file), and then calls the
callback function. *)
+val disk_usage : ?fail:exn callback -> source -> string -> int64 callback -> unit
+ (** [disk_usage src pathname cb] calculates the disk usage of
+ directory [pathname] and calls the callback with the answer
+ (size of {b kilobytes}). *)
+
val discard_command_queue : unit -> unit
(** [discard_command_queue ()] discards any commands on the command
queue.
the slave thread stops working on a command {i and} has no
more commands left in the queue to work on. *)
+val set_status_hook : string callback -> unit
+ (** Set the function in the main thread which is called to
+ update the status bar. The slave thread updates the
+ status bar when an operation starts or stops, keeping the
+ user informed of what is happening. *)
+
val set_progress_hook : (int64 * int64) callback -> unit
(** Set the function in the main thread which is called whenever
the slave thread receives a progress notification message
ws.statusbar_context#pop ();
ignore (ws.statusbar_context#push msg)
-let clear_statusbar ws = set_statusbar ws ""
-
(* Clear the filetree. *)
let clear_view ws =
Filetree.clear ws.view
(* Callback from Connect -> ... menu items. *)
let rec connect_to ws uri =
- (match uri with
- | None -> set_statusbar ws "Connecting to default libvirt ..."
- | Some uri -> set_statusbar ws (sprintf "Connecting to %s ..." uri)
- );
clear_view ws;
Slave.discard_command_queue ();
Slave.connect uri (when_connected ws uri)
(* Called back when connected to a new hypervisor. *)
and when_connected ws uri doms =
- (match uri with
- | None -> set_statusbar ws "Connected to default libvirt"
- | Some uri -> set_statusbar ws (sprintf "Connected to %s" uri)
- );
populate_vmcombo ws doms
and populate_vmcombo ws doms =
(* When a new domain is selected by the user, eg through vmcombo. *)
let rec open_domain ws name =
- set_statusbar ws (sprintf "Opening %s ..." name);
clear_view ws;
Slave.discard_command_queue ();
Slave.open_domain name (when_opened_domain ws name)
(* Called back when domain was opened successfully. *)
and when_opened_domain ws name data =
debug "when_opened_domain callback";
- set_statusbar ws (sprintf "Opened %s" name);
when_opened_common ws name data
(* When a set of disk images is selected by the user. *)
match images with
| [] -> ()
| images ->
- set_statusbar ws "Opening disks ...";
clear_view ws;
Slave.discard_command_queue ();
Slave.open_images images (when_opened_disk_images ws images)
| [] -> ()
| (image, _) :: _ ->
debug "when_opened_disk_images callback";
- set_statusbar ws "Opened disk";
when_opened_common ws image data
(* Common code for when_opened_domain/when_opened_disk_images. *)
)
);
- Filetree.set_status_fn view (set_statusbar ws);
-
(* Return the window_state struct. *)
ws
thread) which are called whenever the throbber should be
animated/busy or idle. *)
+val set_statusbar : window_state -> string -> unit
+ (** This callback from the slave thread (invoked in the main thread)
+ updates the status bar when some slave operation starts or
+ stops. *)
+
val progress : window_state -> int64 * int64 -> unit
(** This called whenever the progress bar should move. *)
git.annexia.org / guestfs-browser.git / commitdiff