*)
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 *)
- | Loading (* special row contains the "Loading ..." message *)
-
-(* The actual content of a row. *)
-and content_t =
- | NoContent
- | 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 renderer = GTree.cell_renderer_text [], ["markup", name_col] in
let name_view = GTree.view_column ~title:"Filename" ~renderer () in
- name_view#set_max_width 400 (*pixels?!?*);
+ name_view#set_max_width 300 (*pixels?!?*);
ignore (view#append_column name_view);
let renderer = GTree.cell_renderer_text [], ["text", size_col] 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;
List.iter (add_top_level_os t name) data.Slave.insp_oses;
(* Add top level left-over filesystems. *)
- DeviceSet.iter (add_top_level_vol t name) other_filesystems
+ DeviceSet.iter (add_top_level_vol t name) other_filesystems;
+
+ (* Expand the first top level node. *)
+ match model#get_iter_first with
+ | None -> ()
+ | Some row ->
+ t.view#expand_row (model#get_path row)
and add_top_level_os ({ model = model; hash = hash } as t) name os =
let markup =
- sprintf "<b>%s</b>: %s (%s)"
- (markup_of_name name) (markup_of_name os.Slave.insp_hostname)
- (markup_of_name os.Slave.insp_product_name) in
+ sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
+ (markup_escape name) (markup_escape os.Slave.insp_hostname)
+ (markup_escape os.Slave.insp_product_name) in
let row = model#append () in
make_node t row (Top (Slave.OS os));
and add_top_level_vol ({ model = model; hash = hash } as t) name dev =
let markup =
- sprintf "<b>%s</b>: %s" (markup_of_name name) (markup_of_name dev) in
+ sprintf "<b>%s</b>\n<small>from %s</small>"
+ (markup_escape dev) (markup_escape name) in
let row = model#append () in
make_node t row (Top (Slave.Volume dev));
* the user has something to expand.
*)
let placeholder = model#append ~parent:row () in
- let hdata = Loading, NoContent 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 =
(* Get a stable path for this row. *)
let path = model#get_path row in
- Slave.read_directory src "/" (when_read_directory t path)
+ Slave.read_directory ~fail:(when_read_directory_fail t path)
+ src "/" (when_read_directory t path)
| NodeNotStarted, Directory direntry ->
(* User has opened a filesystem directory not previously opened. *)
let src, pathname = get_pathname t row in
- Slave.read_directory src pathname (when_read_directory t path)
+ Slave.read_directory ~fail:(when_read_directory_fail t path)
+ src pathname (when_read_directory t path)
| NodeLoading, _ | IsNode, _ -> ()
(* These are not nodes so it should never be possible to open them. *)
- | _, File _ | IsLeaf, _ | Loading, _ -> assert false
-
- (* Should not exist in the tree. *)
- | NodeNotStarted, NoContent -> assert false
+ | _, File _ | IsLeaf, _ -> 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
- | (Loading, NoContent), Some parent ->
- get_pathname t parent
- | (Loading, NoContent), 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 | (_, File _), None -> assert false
- | (_, NoContent), _ -> assert false
+ (* Node should not exist in the tree. *)
+ | NodeNotStarted, (Loading | 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 =
let state, content = get_hdata t row in
let hdata = IsNode, content in
store_hdata t row hdata
+
+(* This is called instead of when_read_directory when the read directory
+ * (or mount etc) failed. Convert the "Loading" entry into the
+ * error message.
+ *)
+and when_read_directory_fail ({ model = model } as t) path exn =
+ debug "when_read_directory_fail: %s" (Printexc.to_string exn);
+
+ match exn with
+ | G.Error msg ->
+ let row = model#get_iter path in
+ let row = model#iter_children ~nth:0 (Some row) in
+
+ let hdata = IsLeaf, ErrorMessage msg in
+ store_hdata t row hdata;
+
+ model#set ~row ~column:t.name_col (markup_escape msg)
+
+ | exn ->
+ (* unexpected exception: re-raise it *)
+ raise exn
+
+let set_status_fn t status =
+ t.status <- Some status
git.annexia.org / guestfs-browser.git / blobdiff