filetree.cmi: slave.cmi
filetree.cmo: utils.cmi slave.cmi filetree_type.cmi filetree_ops.cmi deviceSet.cmi filetree.cmi
filetree.cmx: utils.cmx slave.cmx filetree_type.cmx filetree_ops.cmx deviceSet.cmx filetree.cmi
-filetree_ops.cmi: filetree_type.cmi
-filetree_ops.cmo: utils.cmi filetree_type.cmi filetree_ops.cmi
-filetree_ops.cmx: utils.cmx filetree_type.cmx filetree_ops.cmi
+filetree_ops.cmi: slave.cmi filetree_type.cmi
+filetree_ops.cmo: utils.cmi slave.cmi filetree_type.cmi filetree_ops.cmi
+filetree_ops.cmx: utils.cmx slave.cmx filetree_type.cmx filetree_ops.cmi
filetree_type.cmi: slave.cmi
filetree_type.cmo: utils.cmi slave.cmi filetree_type.cmi
filetree_type.cmx: utils.cmx slave.cmx filetree_type.cmi
# These are listed here in alphabetical order.
SOURCES = \
+ cmdline.mli \
+ cmdline.ml \
config.mli \
config.ml \
deviceSet.mli \
deviceSet.ml \
filetree.mli \
filetree.ml \
+ filetree_ops.mli \
+ filetree_ops.ml \
+ filetree_type.mli \
+ filetree_type.ml \
main.ml \
slave.mli \
slave.ml \
config.cmx \
throbber.cmx \
utils.cmx \
+ cmdline.cmx \
deviceSet.cmx \
slave.cmx \
+ filetree_type.cmx \
+ filetree_ops.cmx \
filetree.cmx \
window.cmx \
main.cmx
-The context menu does nothing at the moment.
+Context menu:
-The menu items do nothing at the moment.
+. Open file (view / open dir)
+. Download
+. Download as tarball
+. File type & info (stat, file, arch, xattrs)
+. Filesystem used & free
+. Disk space usage
+. Block device info (size, UUID, label, ...)
+. Checksum
+x Device checksum (slow?)
+. Directory listing (find0)
+. Inspection data
+? LV information
+? Ext2 superblock info (tune2fs)
+
+Display Windows Registry as a separate tree.
+
+The slave thread should not have to remount filesystems.
+If the mount points are the same as the previous command, it
+should cache them.
+
+About dialog
--- /dev/null
+(* Guestfs Browser.
+ * 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.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Printf
+
+open Utils
+
+type cli_request =
+ | Empty_window
+ | Open_guest of string
+ | Open_images of (string * string option) list
+
+let format = ref None
+let images = ref []
+let guests = ref []
+
+let set_connect = function
+ | "" -> set_connect_uri None
+ | uri -> set_connect_uri (Some uri)
+let set_format = function
+ | "" -> format := None
+ | f -> format := Some f
+let add_image image =
+ images := (image, !format) :: !images
+let add_guest guest =
+ guests := guest :: !guests
+
+(* Parse command line arguments. *)
+let argspec = Arg.align [
+ "-a", Arg.String add_image, "image Open disk image";
+ "--add", Arg.String add_image, "image Open disk image";
+ "-c", Arg.String set_connect, "uri Connect to libvirt URI";
+ "--connect", Arg.String set_connect, "uri Connect to libvirt URI";
+ "-d", Arg.String add_guest, "guest Open libvirt guest";
+ "--domain", Arg.String add_guest, "guest Open libvirt guest";
+ "--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";
+ "-x", Arg.Unit set_trace_flag, " Enable tracing of libguestfs calls";
+]
+
+let prog = Filename.basename Sys.executable_name
+
+let anon_fun _ =
+ raise (Arg.Bad "unknown argument")
+
+let usage_msg =
+ sprintf "\
+%s: graphical guest filesystem browser
+
+Usage:
+ %s
+ Open the program with an empty window.
+
+ %s -a disk.img [-a disk.img [...]]
+ Start with a guest from a disk image file.
+
+ %s -d guest
+ Start with the named libvirt guest.
+
+Options:"
+ prog prog prog prog
+
+let command_line () =
+ Arg.parse argspec anon_fun usage_msg;
+
+ (* Verify number of -a and -d options given on the command line. *)
+ let images = List.rev !images in
+ let guests = List.rev !guests in
+
+ match images, guests with
+ | [], [] -> Empty_window
+ | _, [] -> Open_images images
+ | [], [guest] -> Open_guest guest
+ | [], _ ->
+ failwith "cannot use -d option more than once"
+ | _, _ ->
+ failwith "cannot mix -a and -d options"
--- /dev/null
+(* Guestfs Browser.
+ * 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.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(** Handle the command line arguments. *)
+
+type cli_request =
+ | Empty_window
+ | Open_guest of string
+ | Open_images of (string * string option) list
+ (** The initial action requested by the user on the command line.
+
+ [Empty_window] means nothing was requested on the command line.
+
+ [Open_guest] means to open a guest (-d option).
+
+ [Open_images] means to open a list of disk images (-a option). *)
+
+val command_line : unit -> cli_request
+ (** Read the command line and return {!cli_request}. *)
*)
open ExtString
+open ExtList
open Printf
open Utils
open DeviceSet
+open Filetree_type
+open Filetree_ops
+
module G = Guestfs
-type t = {
- view : GTree.view;
- model : GTree.tree_store;
- hash : (int, hdata) Hashtbl.t; (* hash from index_col -> hdata *)
- index_col : int GTree.column;
- mode_col : string GTree.column;
- name_col : string GTree.column;
- size_col : int64 GTree.column;
- date_col : string GTree.column;
- link_col : string GTree.column;
-}
-
-and hdata = state_t * content_t
-
-(* The type of the hidden column used to implement on-demand loading.
- * All rows are classified as either nodes or leafs (eg. a "node" might
- * be a directory, or a top-level operating system, or anything else
- * which the user could open and look inside).
- *)
-and state_t =
- | IsLeaf (* there are no children *)
- | NodeNotStarted (* user has not tried to open this *)
- | NodeLoading (* user tried to open it, still loading *)
- | IsNode (* we've loaded the children of this directory *)
-
-(* The actual content of a row. *)
-and content_t =
- | Loading (* special "loading ..." node *)
- | ErrorMessage of string (* error message node *)
- | 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 *)
-
-let loading_msg = "<i>Loading ...</i>"
-
-let create ~packing () =
+type t = Filetree_type.t
+
+let rec create ?status ~packing () =
let view = GTree.view ~packing () in
(*view#set_rules_hint true;*)
- view#selection#set_mode `MULTIPLE;
+ (*view#selection#set_mode `MULTIPLE; -- add this later *)
(* Hash of index numbers -> hdata. We do this because it's more
* efficient for the GC compared to storing OCaml objects directly in
let link_view = GTree.view_column ~title:"Link" ~renderer () in
ignore (view#append_column link_view);
- { view = view; model = model; hash = hash;
+ let t = {
+ view = view; model = model; hash = hash;
index_col = index_col;
mode_col = mode_col; name_col = name_col; size_col = size_col;
- date_col = date_col; link_col = link_col }
+ date_col = date_col; link_col = link_col;
+ status = status
+ } in
-let clear { model = model; hash = hash } =
- model#clear ();
- Hashtbl.clear hash
+ (* Open a context menu when a button is pressed. *)
+ ignore (view#event#connect#button_press ~callback:(button_press t));
+
+ t
+
+(* Handle mouse button press on the selected row. This opens the
+ * pop-up context menu.
+ * http://scentric.net/tutorial/sec-selections-context-menus.html
+ *)
+and button_press ({ model = model; view = view } as t) ev =
+ let button = GdkEvent.Button.button ev in
+ let x = int_of_float (GdkEvent.Button.x ev) in
+ let y = int_of_float (GdkEvent.Button.y ev) in
+ let time = GdkEvent.Button.time ev in
+
+ (* Right button for opening the context menu. *)
+ if button = 3 then (
+(*
+ (* If no row is selected, select the row under the mouse. *)
+ let paths =
+ let sel = view#selection in
+ if sel#count_selected_rows < 1 then (
+ match view#get_path_at_pos ~x ~y with
+ | None -> []
+ | Some (path, _, _, _) ->
+ sel#unselect_all ();
+ sel#select_path path;
+ [path]
+ ) else
+ sel#get_selected_rows (* actually returns paths *) in
+*)
+ (* Select the row under the mouse. *)
+ let paths =
+ let sel = view#selection in
+ match view#get_path_at_pos ~x ~y with
+ | None -> []
+ | Some (path, _, _, _) ->
+ sel#unselect_all ();
+ sel#select_path path;
+ [path] in
+
+ (* Get the hdata for all the paths. Filter out rows that it doesn't
+ * make sense to select.
+ *)
+ let paths =
+ List.filter_map (
+ fun path ->
+ let row = model#get_iter path in
+ let hdata = get_hdata t row in
+ match hdata with
+ | _, (Loading | ErrorMessage _) -> None
+ | _, (Top _ | Directory _ | File _) -> Some (path, hdata)
+ ) paths in
+
+ (* Based on number of selected rows and what is selected, construct
+ * the context menu.
+ *)
+ if paths <> [] then (
+ let menu = make_context_menu t paths in
+ menu#popup ~button ~time
+ );
+
+ (* Return true so no other handler will run. *)
+ true
+ )
+ (* We didn't handle this, defer to other handlers. *)
+ else false
+
+and make_context_menu t paths =
+ let menu = GMenu.menu () in
+ let factory = new GMenu.factory menu in
+
+ let item = factory#add_item "Open" in
+ item#misc#set_sensitive false;
+
+ let rec add_file_items path =
+ let item = factory#add_item "File information" in
+ item#misc#set_sensitive false;
+ let item = factory#add_item "Checksum" in
+ item#misc#set_sensitive false;
+ ignore (factory#add_separator ());
+ let item = factory#add_item "Download ..." in
+ ignore (item#connect#activate ~callback:(download_file t path));
+
+ and add_directory_items path =
+ 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 (factory#add_separator ());
+ let item = factory#add_item "Download ..." in
+ item#misc#set_sensitive false;
+ let item = factory#add_item "Download as .tar ..." in
+ ignore (item#connect#activate
+ ~callback:(download_dir_tarball t Slave.Tar path));
+ let item = factory#add_item "Download as .tar.gz ..." in
+ ignore (item#connect#activate
+ ~callback:(download_dir_tarball t Slave.TGZ path));
+ let item = factory#add_item "Download as .tar.xz ..." in
+ ignore (item#connect#activate
+ ~callback:(download_dir_tarball t Slave.TXZ path));
+ let item = factory#add_item "Download list of filenames ..." in
+ ignore (item#connect#activate ~callback:(download_dir_find0 t path));
+
+ and add_os_items path =
+ let item = factory#add_item "Operating system information" in
+ item#misc#set_sensitive false;
+ let item = factory#add_item "Block device information" in
+ item#misc#set_sensitive false;
+ let item = factory#add_item "Filesystem used & free" in
+ item#misc#set_sensitive false;
+ ignore (factory#add_separator ());
+ add_directory_items path
+
+ and add_volume_items path =
+ let item = factory#add_item "Filesystem used & free" in
+ item#misc#set_sensitive false;
+ let item = factory#add_item "Block device information" in
+ item#misc#set_sensitive false;
+ ignore (factory#add_separator ());
+ add_directory_items path
+ in
+
+ (match paths with
+ (* single selection *)
+ | [path, (_, Top (Slave.OS os))] -> (* top level operating system *)
+ add_os_items path
+
+ | [path, (_, Top (Slave.Volume dev))] -> (* top level volume *)
+ add_volume_items path
+
+ | [path, (_, Directory direntry)] -> (* directory *)
+ add_directory_items path
+
+ | [path, (_, File direntry)] -> (* file *)
+ add_file_items path
+
+ | [_, (_, Loading)]
+ | [_, (_, ErrorMessage _)] -> ()
+
+ | _ ->
+ (* At the moment multiple selection is disabled. When/if we
+ * enable it we should do something intelligent here. XXX
+ *)
+ ()
+ );
+
+ menu
(* XXX No binding for g_markup_escape in lablgtk2. *)
let markup_escape name =
(tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
-(* Store hdata into a row. *)
-let store_hdata {model = model; hash = hash; index_col = index_col} row hdata =
- let index = unique () in
- Hashtbl.add hash index hdata;
- model#set ~row ~column:index_col index
-
-(* Retrieve previously stored hdata from a row. *)
-let get_hdata { model = model; hash = hash; index_col = index_col } row =
- let index = model#get ~row ~column:index_col in
- try Hashtbl.find hash index
- with Not_found -> assert false
+let clear { model = model; hash = hash } =
+ model#clear ();
+ Hashtbl.clear hash
let rec add ({ model = model; hash = hash } as t) name data =
clear t;
let placeholder = model#append ~parent:row () in
let hdata = IsLeaf, Loading in
store_hdata t placeholder hdata;
- model#set ~row:placeholder ~column:t.name_col loading_msg;
+ model#set ~row:placeholder ~column:t.name_col "<i>Loading ...</i>";
ignore (t.view#connect#row_expanded ~callback:(expand_row t))
and make_leaf ({ model = model; hash = hash } as t) row content =
(* Node should not exist in the tree. *)
| NodeNotStarted, (Loading | ErrorMessage _) -> assert false
-(* 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.
- *
- * The path up the tree will always look something like:
- * Top
- * \_ Directory
- * \_ Directory
- * \_ Loading <--- you are here
- *)
-and get_pathname ({ model = model } as t) row =
- let hdata = get_hdata t row in
- let parent = model#iter_parent row in
-
- match hdata, parent with
- | (IsLeaf, Loading), Some parent ->
- get_pathname t parent
- | (IsLeaf, Loading), None ->
- assert false
- | (_, Directory { Slave.dent_name = name }), Some parent
- | (_, File { Slave.dent_name = name }), Some parent ->
- let src, parent_name = get_pathname t parent in
- let path =
- if parent_name = "/" then "/" ^ name
- else parent_name ^ "/" ^ name in
- src, path
- | (_, Top src), _ -> src, "/"
- | (_, Directory _), None -> assert false
- | (_, File _), None -> assert false
- | (_, Loading), _ -> assert false
- | (_, ErrorMessage _), _ -> 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 =
debug "when_read_directory";
| exn ->
(* unexpected exception: re-raise it *)
raise exn
+
+let set_status_fn t status =
+ t.status <- Some status
http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html *)
type t
+ (** A filetree widget. Actually an opaque object which contains the
+ widget and other data. Use the accessors below. *)
-val create : packing:(GObj.widget -> unit) -> unit -> t
- (** Create a new filetree widget (empty). *)
+val create : ?status:(string -> unit) -> 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
(** Clear out all rows in existing widget. *)
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. *)
--- /dev/null
+(* Guestfs Browser.
+ * 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.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Printf
+
+open Utils
+
+open Filetree_type
+
+(* Get the basename of a file, using path conventions which are valid
+ * for libguestfs. So [Filename.basename] won't necessarily work
+ * because it will use host path conventions.
+ *)
+let basename pathname =
+ let len = String.length pathname in
+ try
+ let i = String.rindex pathname '/' in
+ let r = String.sub pathname (i+1) (len-i-1) in
+ if r = "" then "root" else r
+ with
+ Not_found -> pathname
+
+(* Download a single file. *)
+let rec download_file ({ model = model } as t) path () =
+ let row = model#get_iter path in
+ let src, pathname = get_pathname t row in
+ debug "download_file %s: showing dialog" pathname;
+
+ (* Put up the dialog. *)
+ let title = "Download file" in
+ let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
+ dlg#add_button_stock `CANCEL `CANCEL;
+ dlg#add_select_button_stock `SAVE `SAVE;
+ dlg#set_current_name (basename pathname);
+
+ match dlg#run () with
+ | `DELETE_EVENT | `CANCEL ->
+ dlg#destroy ()
+ | `SAVE ->
+ match dlg#filename with
+ | None -> ()
+ | Some localfile ->
+ 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)
+
+(* Download a directory as a tarball. *)
+let rec download_dir_tarball ({ model = model } as t) format path () =
+ let row = model#get_iter path in
+ let src, pathname = get_pathname t row in
+ debug "download_dir_tarball %s: showing dialog" pathname;
+
+ (* Put up the dialog. *)
+ let title = "Download directory to tar file" in
+ let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
+ dlg#add_button_stock `CANCEL `CANCEL;
+ dlg#add_select_button_stock `SAVE `SAVE;
+
+ let extension = match format with
+ | Slave.Tar -> ".tar"
+ | Slave.TGZ -> ".tar.gz"
+ | Slave.TXZ -> ".tar.xz"
+ in
+ dlg#set_current_name (basename pathname ^ extension);
+
+ match dlg#run () with
+ | `DELETE_EVENT | `CANCEL ->
+ dlg#destroy ()
+ | `SAVE ->
+ match dlg#filename with
+ | None -> ()
+ | Some localfile ->
+ 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)
+
+let rec download_dir_find0 ({ model = model } as t) path () =
+ let row = model#get_iter path in
+ let src, pathname = get_pathname t row in
+ debug "download_dir_find0 %s: showing dialog" pathname;
+
+ (* Put up the dialog. *)
+ let title = "Download list of filenames" in
+ let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
+ dlg#add_button_stock `CANCEL `CANCEL;
+ dlg#add_select_button_stock `SAVE `SAVE;
+ dlg#set_current_name (basename pathname ^ ".filenames.txt");
+
+ (* Notify that the list of strings is \0 separated. *)
+ let hbox =
+ let hbox = GPack.hbox () in
+ ignore (GMisc.image ~stock:`INFO ~packing:hbox#pack ());
+ let label = GMisc.label
+ ~text:"The list of filenames is saved to a file with zero byte separators, to allow the full range of characters to be used in the names themselves."
+ ~packing:hbox#pack () in
+ label#set_line_wrap true;
+ hbox in
+ dlg#set_extra_widget (hbox :> GObj.widget);
+
+ match dlg#run () with
+ | `DELETE_EVENT | `CANCEL ->
+ dlg#destroy ()
+ | `SAVE ->
+ match dlg#filename with
+ | None -> ()
+ | Some localfile ->
+ 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)
+
+and when_downloaded_dir_find0 t _ localfile () =
+ update_status t (sprintf "Finished downloading %s" localfile)
--- /dev/null
+(* Guestfs Browser.
+ * 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.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(** Operations on a file tree.
+
+ This module contains operations performed by menu items or
+ from the context menu.
+
+ The types and functions in this file should be considered
+ private to the file tree implementation.
+
+ See {!Filetree} for the full description and public interface. *)
+
+(**/**)
+
+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
+
+val download_dir_find0 : Filetree_type.t -> Gtk.tree_path -> unit -> unit
--- /dev/null
+(* Guestfs Browser.
+ * 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.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Utils
+
+type t = {
+ view : GTree.view;
+ model : GTree.tree_store;
+ hash : (int, hdata) Hashtbl.t; (* hash from index_col -> hdata *)
+ index_col : int GTree.column;
+ mode_col : string GTree.column;
+ name_col : string GTree.column;
+ 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
+
+(* The type of the hidden column used to implement on-demand loading.
+ * All rows are classified as either nodes or leafs (eg. a "node" might
+ * be a directory, or a top-level operating system, or anything else
+ * which the user could open and look inside).
+ *)
+and state_t =
+ | IsLeaf (* there are no children *)
+ | NodeNotStarted (* user has not tried to open this *)
+ | NodeLoading (* user tried to open it, still loading *)
+ | IsNode (* we've loaded the children of this directory *)
+
+(* The actual content of a row. *)
+and content_t =
+ | Loading (* special "loading ..." node *)
+ | ErrorMessage of string (* error message node *)
+ | 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 *)
+
+(* Store hdata into a row. *)
+let store_hdata {model = model; hash = hash; index_col = index_col} row hdata =
+ let index = unique () in
+ Hashtbl.add hash index hdata;
+ model#set ~row ~column:index_col index
+
+(* Retrieve previously stored hdata from a row. *)
+let get_hdata { model = model; hash = hash; index_col = index_col } row =
+ let index = model#get ~row ~column:index_col in
+ try Hashtbl.find hash index
+ with Not_found -> assert false
+
+(* 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.
+ *
+ * The path up the tree will always look something like:
+ * Top
+ * \_ Directory
+ * \_ Directory
+ * \_ Loading <--- you are here
+ *)
+let rec get_pathname ({ model = model } as t) row =
+ let hdata = get_hdata t row in
+ let parent = model#iter_parent row in
+
+ match hdata, parent with
+ | (IsLeaf, Loading), Some parent ->
+ get_pathname t parent
+ | (IsLeaf, Loading), None ->
+ assert false
+ | (_, Directory { Slave.dent_name = name }), Some parent
+ | (_, File { Slave.dent_name = name }), Some parent ->
+ let src, parent_name = get_pathname t parent in
+ let path =
+ if parent_name = "/" then "/" ^ name
+ else parent_name ^ "/" ^ name in
+ src, path
+ | (_, Top src), _ -> src, "/"
+ | (_, Directory _), None -> assert false
+ | (_, 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
--- /dev/null
+(* Guestfs Browser.
+ * 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.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(** This is the base class for the file tree.
+
+ The types and functions in this file should be considered
+ private to the file tree implementation.
+
+ See {!Filetree} for the full description and public interface. *)
+
+(**/**)
+
+type t = {
+ view : GTree.view;
+ model : GTree.tree_store;
+ hash : (int, hdata) Hashtbl.t;
+ index_col : int GTree.column;
+ mode_col : string GTree.column;
+ name_col : string GTree.column;
+ 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 state_t =
+ | IsLeaf
+ | NodeNotStarted
+ | NodeLoading
+ | IsNode
+
+and content_t =
+ | Loading
+ | ErrorMessage of string
+ | Top of Slave.source
+ | Directory of Slave.direntry
+ | File of Slave.direntry
+
+val store_hdata : t -> Gtk.tree_iter -> hdata -> unit
+val get_hdata : t -> Gtk.tree_iter -> hdata
+ (* Store/retrieve hdata structure in a model row. *)
+
+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. *)
(* Main. *)
let () =
- (* XXX command line *)
- Utils.set_verbose_flag ();
+ let cli_request = Cmdline.command_line () in
(* If we're in verbose mode, print some debug information which
* could be useful in bug reports.
Slave.set_progress_hook (Window.progress ws);
(* What did the user request on the command line? *)
- (*Window.run_cli_request ws cli_request;*)
+ Window.run_cli_request ws cli_request;
(* Run the main display thread. When this returns, the application
* has been closed.
type command =
| Exit_thread
| Connect of string option * domain list 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
| Open_domain of string * inspection_data callback
| Open_images of (string * string option) list * inspection_data callback
| Read_directory of source * string * direntry list callback
dent_link : string;
}
+and download_dir_tarball_format = Tar | TGZ | TXZ
+
let rec string_of_command = function
| Exit_thread -> "Exit_thread"
| Connect (Some name, _) -> sprintf "Connect %s" name
| Connect (None, _) -> "Connect NULL"
+ | Download_dir_find0 (src, remotedir, localfile, _) ->
+ sprintf "Download_dir_find0 (%s, %s, %s)"
+ (string_of_source src) remotedir localfile
+ | Download_dir_tarball (src, remotedir, format, localfile, _) ->
+ sprintf "Download_dir_tarball (%s, %s, %s, %s)"
+ (string_of_source src) remotedir
+ (string_of_download_dir_tarball_format format) localfile
+ | Download_file (src, remotefile, localfile, _) ->
+ sprintf "Download_file (%s, %s, %s)"
+ (string_of_source src) remotefile localfile
| Open_domain (name, _) -> sprintf "Open_domain %s" name
| Open_images (images, _) ->
sprintf "Open_images %s" (string_of_images images)
- | Read_directory (OS { insp_root = root }, dir, _) ->
- sprintf "Read_directory (OS %s, %s)" root dir
- | Read_directory (Volume dev, dir, _) ->
- sprintf "Read_directory (Volume %s, %s)" dev dir
+ | Read_directory (src, dir, _) ->
+ sprintf "Read_directory (%s, %s)" (string_of_source src) dir
and string_of_images images =
"[" ^
| fn, Some format -> sprintf "%s (%s)" fn format)
images) ^ "]"
+and string_of_source = function
+ | OS { insp_root = root } ->
+ sprintf "OS %s" root
+ | Volume dev ->
+ sprintf "Volume %s" dev
+
+and string_of_download_dir_tarball_format = function
+ | Tar -> "Tar"
+ | TGZ -> "TGZ"
+ | TXZ -> "TXZ"
+
let no_callback _ = ()
let failure_hook = ref (fun _ -> ())
)
let connect ?fail uri cb = send_to_slave ?fail (Connect (uri, 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 =
+ send_to_slave ?fail
+ (Download_dir_tarball (src, remotedir, format, localfile, cb))
+let download_file ?fail src remotefile localfile cb =
+ send_to_slave ?fail (Download_file (src, remotefile, localfile, cb))
let open_domain ?fail name cb = send_to_slave ?fail (Open_domain (name, cb))
let open_images ?fail images cb = send_to_slave ?fail (Open_images (images, cb))
let read_directory ?fail src path cb =
let doms = List.sort ~cmp doms in
callback_if_not_discarded cb doms
+ | Download_dir_find0 (src, remotedir, localfile, cb) ->
+ let g = get_g () in
+ with_mount_ro g src (
+ fun () ->
+ g#find0 remotedir localfile
+ );
+ callback_if_not_discarded cb ()
+
+ | Download_dir_tarball (src, remotedir, format, localfile, cb) ->
+ let g = get_g () in
+ let f = match format with
+ | Tar -> g#tar_out
+ | TGZ -> g#tgz_out
+ | TXZ -> g#txz_out
+ in
+ with_mount_ro g src (
+ fun () ->
+ f remotedir localfile
+ );
+ callback_if_not_discarded cb ()
+
+ | Download_file (src, remotefile, localfile, cb) ->
+ let g = get_g () in
+ with_mount_ro g src (
+ fun () ->
+ g#download remotefile localfile
+ );
+ callback_if_not_discarded cb ()
+
| Open_domain (name, cb) ->
let conn = get_conn () in
let dom = D.lookup_by_name conn name in
g := Some g';
let g = g' in
+ g#set_trace (trace ());
+
(* Uncomment the next line to pass the verbose flag from the command
* line through to libguestfs. This is not generally necessary since
* we are not so interested in debugging libguestfs problems at this
If [fail] is passed, then failures cause this callback to
be called. If not, the global failure hook is called. *)
+val download_file : ?fail:exn callback -> source -> string -> string -> unit callback -> unit
+ (** [download_file src pathname localfile cb] downloads [pathname]
+ to the named local file, and then calls the callback function. *)
+
+type download_dir_tarball_format = Tar | TGZ | TXZ
+
+val download_dir_tarball : ?fail:exn callback -> source -> string -> download_dir_tarball_format -> string -> unit callback -> unit
+ (** [download_dir_tarball_format src pathname format localfile cb]
+ downloads directory [pathname] to the named local file (a
+ tarball), and then calls the callback function.
+
+ [format] controls the download format, which is one of
+ uncompressed tar, gzip-compressed tar, or xz-compressed tar. *)
+
+val download_dir_find0 : ?fail:exn callback -> source -> string -> string -> unit callback -> unit
+ (** [download_dir_find0 src pathname localfile cb] downloads the
+ list of filenames of directory [pathname] to the named local
+ file (a ASCII NUL-separated text file), and then calls the
+ callback function. *)
+
val discard_command_queue : unit -> unit
(** [discard_command_queue ()] discards any commands on the command
queue.
in
ksprintf f fs
+let trace = ref false
+let set_trace_flag () = trace := true
+let trace () = !trace
+
+let connect_uri = ref None
+let set_connect_uri conn = connect_uri := conn
+let connect_uri () = !connect_uri
+
let utf8_rarrow = "\xe2\x86\x92"
let human_size_1k i =
take a printf-like argument list, and also logs errors on stderr
when verbose is enabled. *)
+val trace : unit -> bool
+val set_trace_flag : unit -> unit
+ (** If this contains [true] then calls to libguestfs are traced.
+
+ This is set through the [-x] command line option. *)
+
+val connect_uri : unit -> string option
+val set_connect_uri : string option -> unit
+ (** The libvirt connection URI.
+
+ This is set through the [--connect] command line option. *)
+
val utf8_rarrow : string (** UTF-8 RIGHTWARDS ARROW *)
val human_size_1k : int64 -> string
| 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 =
(* Populate the VM combo box. *)
let combo, (model, column) = ws.vmcombo in
model#clear ();
)
);
+ Filetree.set_status_fn view (set_statusbar ws);
+
+ (* Return the window_state struct. *)
ws
and make_menubar window vbox ~packing () =
let sw =
GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in
Filetree.create ~packing:sw#add ()
+
+(* Do what the user asked on the command line. *)
+let rec run_cli_request ws = function
+ | Cmdline.Empty_window -> ()
+ | Cmdline.Open_images images ->
+ open_disk_images ws images
+ | Cmdline.Open_guest guest ->
+ (* Open libvirt connection, and in the callback open the guest. *)
+ let uri = connect_uri () in
+ Slave.connect uri (when_connected_cli_request ws guest)
+and when_connected_cli_request ws guest doms =
+ populate_vmcombo ws doms;
+
+ (* "guest" should match a domain in "doms". Check this and
+ * get the index of it.
+ *)
+ let rec loop i = function
+ | [] ->
+ failwith "guest %s not found (do you need to use --connect?)" guest
+ | d::ds when d = guest -> i
+ | _::ds -> loop (i+1) ds
+ in
+ let i = loop 0 (List.map (fun { Slave.dom_name = name } -> name) doms) in
+
+ let combo, _ = ws.vmcombo in
+ combo#set_active i
val progress : window_state -> int64 * int64 -> unit
(** This called whenever the progress bar should move. *)
-(*
- val run_cli_request : window_state -> Cmdline.cli_request -> unit
-(** This function performs the {!Cmdline.cli_request} operation.
- The actual operation happens asynchronously after this function
- has returned. *)
-*)
+val run_cli_request : window_state -> Cmdline.cli_request -> unit
+ (** This function performs the {!Cmdline.cli_request} operation.
+ The actual operation happens asynchronously after this function
+ has returned. *)
git.annexia.org / guestfs-browser.git / commitdiff