From 02614e74adee2a5d499bd557a6adde99a3c56e73 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 14 Dec 2010 22:36:41 +0000 Subject: [PATCH] Version 0.1.1. --- configure.ac | 2 +- filetree.ml | 178 ++++++++++++++++++++++++++---------------------------- filetree_ops.ml | 84 ++++++++++++++++++++++---- filetree_ops.mli | 2 + filetree_type.ml | 147 ++++++++++++++++++++++++++++++++++---------- filetree_type.mli | 55 +++++++++++------ utils.ml | 61 +++++++++++++++++-- utils.mli | 38 +++++++++++- window.ml | 28 ++++++++- 9 files changed, 427 insertions(+), 168 deletions(-) diff --git a/configure.ac b/configure.ac index a7db870..14c3bc7 100644 --- a/configure.ac +++ b/configure.ac @@ -15,7 +15,7 @@ dnl You should have received a copy of the GNU General Public License along dnl with this program; if not, write to the Free Software Foundation, Inc., dnl 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -AC_INIT([guestfs-browser],[0.1.0]) +AC_INIT([guestfs-browser],[0.1.1]) AM_INIT_AUTOMAKE([foreign]) AC_CONFIG_MACRO_DIR([m4]) diff --git a/filetree.ml b/filetree.ml index c4f62ab..f252f2a 100644 --- a/filetree.ml +++ b/filetree.ml @@ -18,6 +18,7 @@ open ExtString open ExtList +open Unix open Printf open Utils @@ -52,40 +53,40 @@ let rec create ~packing () = (* Displayed: *) let mode_col = cols#add Gobject.Data.string in let name_col = cols#add Gobject.Data.string in - let size_col = cols#add Gobject.Data.int64 in + let size_col = cols#add Gobject.Data.string in let date_col = cols#add Gobject.Data.string in - let link_col = cols#add Gobject.Data.string in (* Create the model. *) let model = GTree.tree_store cols in + + (* Create the view. *) view#set_model (Some (model :> GTree.model)); let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in + mode_view#set_resizable true; ignore (view#append_column mode_view); 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 300 (*pixels?!?*); + name_view#set_resizable true; ignore (view#append_column name_view); - let renderer = GTree.cell_renderer_text [], ["text", size_col] in + let renderer = GTree.cell_renderer_text [`XALIGN 1.], ["markup", size_col] in let size_view = GTree.view_column ~title:"Size" ~renderer () in + size_view#set_resizable true; ignore (view#append_column size_view); - let renderer = GTree.cell_renderer_text [], ["markup", date_col] in + let renderer = GTree.cell_renderer_text [`XALIGN 1.], ["markup", date_col] in let date_view = GTree.view_column ~title:"Date" ~renderer () in + date_view#set_resizable true; ignore (view#append_column date_view); - let renderer = GTree.cell_renderer_text [], ["markup", link_col] in - let link_view = GTree.view_column ~title:"Link" ~renderer () in - ignore (view#append_column link_view); - 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; } in (* Open a context menu when a button is pressed. *) @@ -138,8 +139,8 @@ and button_press ({ model = model; view = view } as t) ev = let row = model#get_iter path in let hdata = get_hdata t row in match hdata with - | _, (Loading | ErrorMessage _ | Info _) -> None - | _, (Top _ | Directory _ | File _) -> Some (path, hdata) + | { content=(Loading | ErrorMessage _ | Info _) } -> None + | { content=(Top _ | Directory _ | File _) } -> Some (path, hdata) ) paths in (* Based on number of selected rows and what is selected, construct @@ -175,7 +176,7 @@ and make_context_menu t paths = 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 + let item = factory#add_item "Calculate disk usage" in ignore (item#connect#activate ~callback:(disk_usage t path)); ignore (factory#add_separator ()); let item = factory#add_item "Download ..." in @@ -194,13 +195,9 @@ and make_context_menu t paths = 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 (item#connect#activate ~callback:(display_inspection_data t path)); ignore (factory#add_separator ()); - add_directory_items path + add_volume_items path and add_volume_items path = let item = factory#add_item "Filesystem used & free" in @@ -213,20 +210,20 @@ and make_context_menu t paths = (match paths with (* single selection *) - | [path, (_, Top (Slave.OS os))] -> (* top level operating system *) + | [path, { content=Top (Slave.OS os)} ] -> (* top level operating system *) add_os_items path - | [path, (_, Top (Slave.Volume dev))] -> (* top level volume *) + | [path, { content=Top (Slave.Volume dev) }] -> (* top level volume *) add_volume_items path - | [path, (_, Directory direntry)] -> (* directory *) + | [path, { content=Directory direntry }] -> (* directory *) add_directory_items path - | [path, (_, File direntry)] -> (* file *) + | [path, { content=File direntry }] -> (* file *) add_file_items path - | [_, (_, Loading)] - | [_, (_, ErrorMessage _)] -> () + | [_, { content=Loading }] + | [_, { content=ErrorMessage _ }] -> () | _ -> (* At the moment multiple selection is disabled. When/if we @@ -237,25 +234,8 @@ and make_context_menu t paths = menu -(* XXX No binding for g_markup_escape in lablgtk2. *) -let markup_escape name = - let f = function - | '&' -> "&" | '<' -> "<" | '>' -> ">" - | c -> String.make 1 c - in - String.replace_chars f name - -(* Mark up a filename for the name_col column. *) -let rec markup_of_name name = - markup_escape name - -(* Mark up symbolic links. *) -and markup_of_link link = - let link = markup_escape link in - if link <> "" then utf8_rarrow ^ " " ^ link else "" - (* Mark up mode. *) -and markup_of_mode mode = +let markup_of_mode mode = let c = if is_socket mode then 's' else if is_symlink mode then 'l' @@ -264,46 +244,59 @@ and markup_of_mode mode = else if is_directory mode then 'd' else if is_char mode then 'c' else if is_fifo mode then 'p' else '?' in - let ru = if test_bit 0o400L mode then 'r' else '-' in - let wu = if test_bit 0o200L mode then 'w' else '-' in - let xu = if test_bit 0o100L mode then 'x' else '-' in - let rg = if test_bit 0o40L mode then 'r' else '-' in - let wg = if test_bit 0o20L mode then 'w' else '-' in - let xg = if test_bit 0o10L mode then 'x' else '-' in - let ro = if test_bit 0o4L mode then 'r' else '-' in - let wo = if test_bit 0o2L mode then 'w' else '-' in - let xo = if test_bit 0o1L mode then 'x' else '-' in + let ru = if is_ru mode then 'r' else '-' in + let wu = if is_wu mode then 'w' else '-' in + let xu = if is_xu mode then 'x' else '-' in + let rg = if is_rg mode then 'r' else '-' in + let wg = if is_wg mode then 'w' else '-' in + let xg = if is_xg mode then 'x' else '-' in + let ro = if is_ro mode then 'r' else '-' in + let wo = if is_wo mode then 'w' else '-' in + let xo = if is_xo mode then 'x' else '-' in let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in - let suid = test_bit 0o4000L mode in - let sgid = test_bit 0o2000L mode in - let svtx = test_bit 0o1000L mode in + let suid = is_suid mode in + let sgid = is_sgid mode in + let svtx = is_svtx mode in if suid then str.[3] <- 's'; if sgid then str.[6] <- 's'; if svtx then str.[9] <- 't'; "" ^ str ^ "" -(* File type tests. *) -and file_type mask mode = Int64.logand mode 0o170000L = mask - -and is_socket mode = file_type 0o140000L mode -and is_symlink mode = file_type 0o120000L mode -and is_regular_file mode = file_type 0o100000L mode -and is_block mode = file_type 0o060000L mode -and is_directory mode = file_type 0o040000L mode -and is_char mode = file_type 0o020000L mode -and is_fifo mode = file_type 0o010000L mode +(* Mark up dates. *) +let markup_of_date t = + (* Guestfs gives us int64's, we want float which is OCaml's + * equivalent of time_t. + *) + let t = Int64.to_float t in -and test_bit mask mode = Int64.logand mode mask = mask + let show_full_date () = + let tm = localtime t in + sprintf "%04d-%02d-%02d %02d:%02d:%02d" + (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday + tm.tm_hour tm.tm_min tm.tm_sec + in -(* Mark up dates. *) -and markup_of_date time = - let time = Int64.to_float time in - let tm = Unix.localtime time in - sprintf "%04d-%02d-%02d %02d:%02d:%02d" - (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 + (* How long ago? *) + let now = time () in + let ago = now -. t in + if ago < 0. then (* future *) + show_full_date () + else if ago < 60. then + "now" + else if ago < 60. *. 60. then + sprintf "%.0f minutes ago" (ago /. 60.) + else if ago < 60. *. 60. *. 24. then + sprintf "%.0f hours ago" (ago /. 60. /. 60.) + else if ago < 60. *. 60. *. 24. *. 28. then + sprintf "%.0f days ago" (ago /. 60. /. 60. /. 24.) + else + show_full_date () + +(* Mark up file sizes. *) +let markup_of_size bytes = + sprintf "%s" (human_size bytes) let clear { model = model; hash = hash } = model#clear (); @@ -358,31 +351,30 @@ and add_top_level_vol ({ model = model; hash = hash } as t) name dev = (* Generic function to make an openable node to the tree. *) and make_node ({ model = model; hash = hash } as t) row content = - let hdata = NodeNotStarted, content in + let hdata = { state=NodeNotStarted; content=content; visited=false } in store_hdata t row hdata; (* Create a placeholder "loading ..." row underneath this node so * the user has something to expand. *) let placeholder = model#append ~parent:row () in - let hdata = IsLeaf, Loading in + let hdata = { state=IsLeaf; content=Loading; visited=false } in store_hdata t placeholder hdata; model#set ~row:placeholder ~column:t.name_col "Loading ..."; ignore (t.view#connect#row_expanded ~callback:(expand_row t)) and make_leaf ({ model = model; hash = hash } as t) row content = - let hdata = IsLeaf, content in + let hdata = { state=IsLeaf; content=content; visited=false } in store_hdata t row hdata (* This is called when the user expands a row. *) and expand_row ({ model = model; hash = hash } as t) row _ = match get_hdata t row with - | NodeNotStarted, Top src -> + | { state=NodeNotStarted; content=Top src } as hdata -> (* User has opened a top level node that was not previously opened. *) (* Mark this row as loading, so we don't try to open it again. *) - let hdata = NodeLoading, Top src in - store_hdata t row hdata; + hdata.state <- NodeLoading; (* Get a stable path for this row. *) let path = model#get_path row in @@ -390,12 +382,11 @@ and expand_row ({ model = model; hash = hash } as t) row _ = Slave.read_directory ~fail:(when_read_directory_fail t path) src "/" (when_read_directory t path) - | NodeNotStarted, Directory direntry -> + | { state=NodeNotStarted; content=Directory direntry } as hdata -> (* User has opened a filesystem directory not previously opened. *) (* Mark this row as loading. *) - let hdata = NodeLoading, Directory direntry in - store_hdata t row hdata; + hdata.state <- NodeLoading; (* Get a stable path for this row. *) let path = model#get_path row in @@ -405,13 +396,14 @@ and expand_row ({ model = model; hash = hash } as t) row _ = Slave.read_directory ~fail:(when_read_directory_fail t path) src pathname (when_read_directory t path) - | NodeLoading, _ | IsNode, _ -> () + | { state=(NodeLoading|IsNode) } -> () (* These are not nodes so it should never be possible to open them. *) - | _, File _ | IsLeaf, _ -> assert false + | { content=File _ } | { state=IsLeaf } -> assert false (* Node should not exist in the tree. *) - | NodeNotStarted, (Loading | ErrorMessage _ | Info _) -> assert false + | { state=NodeNotStarted; content=(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 = @@ -429,19 +421,17 @@ and when_read_directory ({ model = model } as t) path entries = make_node t row (Directory direntry) else make_leaf t row (File direntry); - model#set ~row ~column:t.name_col (markup_of_name name); + model#set ~row ~column:t.name_col (markup_of_name direntry); model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode); - model#set ~row ~column:t.size_col stat.G.size; + model#set ~row ~column:t.size_col (markup_of_size stat.G.size); model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime); - model#set ~row ~column:t.link_col (markup_of_link link) ) entries; (* Remove the placeholder "Loading" entry. NB. Must be done AFTER * adding the other entries, or else Gtk will unexpand the row. *) (try - let hdata = IsLeaf, Loading in - let row = find_child_node_by_hdata t row hdata in + let row = find_child_node_by_content t row Loading in ignore (model#remove row) with Invalid_argument _ | Not_found -> () ); @@ -449,9 +439,9 @@ and when_read_directory ({ model = model } as t) path entries = (* The original directory entry has now been loaded, so * update its state. *) - let state, content = get_hdata t row in - let hdata = IsNode, content in - store_hdata t row hdata + let hdata = get_hdata t row in + hdata.state <- IsNode; + set_visited t row (* This is called instead of when_read_directory when the read directory * (or mount etc) failed. Convert the "Loading" entry into the @@ -465,7 +455,7 @@ and when_read_directory_fail ({ model = model } as t) path exn = let row = model#get_iter path in let row = model#iter_children ~nth:0 (Some row) in - let hdata = IsLeaf, ErrorMessage msg in + let hdata = { state=IsLeaf; content=ErrorMessage msg; visited=false } in store_hdata t row hdata; model#set ~row ~column:t.name_col (markup_escape msg) diff --git a/filetree_ops.ml b/filetree_ops.ml index 264c46e..93ecb62 100644 --- a/filetree_ops.ml +++ b/filetree_ops.ml @@ -58,7 +58,12 @@ let rec download_file ({ model = model } as t) path () = dlg#destroy (); (* Download the file. *) - Slave.download_file src pathname localfile Slave.no_callback + Slave.download_file src pathname localfile + (when_downloaded_file t path) + +and when_downloaded_file ({ model = model } as t) path () = + let row = model#get_iter path in + set_visited t row (* Download a directory as a tarball. *) let rec download_dir_tarball ({ model = model } as t) format path () = @@ -90,7 +95,11 @@ let rec download_dir_tarball ({ model = model } as t) format path () = (* Download the directory. *) Slave.download_dir_tarball src pathname format localfile - Slave.no_callback + (when_downloaded_dir_tarball t path) + +and when_downloaded_dir_tarball ({ model = model } as t) path () = + let row = model#get_iter path in + set_visited t row let rec download_dir_find0 ({ model = model } as t) path () = let row = model#get_iter path in @@ -125,10 +134,15 @@ let rec download_dir_find0 ({ model = model } as t) path () = dlg#destroy (); (* Download the directory. *) - Slave.download_dir_find0 src pathname localfile Slave.no_callback + Slave.download_dir_find0 src pathname localfile + (when_downloaded_dir_find0 t path) + +and when_downloaded_dir_find0 ({ model = model } as t) path () = + let row = model#get_iter path in + set_visited t row -let has_child_node_equals t row hdata = - try ignore (find_child_node_by_hdata t row hdata); true +let has_child_node_equals t row content = + try ignore (find_child_node_by_content t row content); true with Not_found -> false (* Calculate disk space used by a directory. *) @@ -142,26 +156,70 @@ let rec disk_usage ({ model = model } as t) path () = (* 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 ( + let content = Info "disk_usage" in + if not (has_child_node_equals t row content) then ( (* Create the child node first. *) let row = model#insert ~parent:row 0 in - store_hdata t row hdata; + store_hdata t row { state=IsLeaf; content=content; visited=false }; model#set ~row ~column:t.name_col "Calculating disk usage ..."; - Slave.disk_usage src pathname (when_disk_usage t path) + Slave.disk_usage src pathname (when_disk_usage t path pathname) ) -and when_disk_usage ({ model = model } as t) path kbytes = +and when_disk_usage ({ model = model } as t) path pathname kbytes = let row = model#get_iter path in (* 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 "Disk usage: %Ld KB" kbytes in + let content = Info "disk_usage" in + let row = find_child_node_by_content t row content in + let msg = + sprintf "%s\nDisk usage of %s (%Ld KB)" + (human_size_1k kbytes) pathname kbytes in model#set ~row ~column:t.name_col msg with Not_found -> () + +(* Display operating system inspection information. *) +let display_inspection_data ({ model = model } as t) path () = + t.view#expand_row path; + + let row = model#get_iter path in + let src, _ = get_pathname t row in + debug "display_inspection_data"; + + (* Should be an OS source, if not ignore. *) + match src with + | Slave.Volume _ -> () + | Slave.OS os -> + (* See if this node already has an Info "inspection_data" child + * node. If so they don't recreate it. + *) + let content = Info "inspection_data" in + if not (has_child_node_equals t row content) then ( + let row = model#insert ~parent:row 0 in + store_hdata t row { state=IsLeaf; content=content; visited=false }; + + (* XXX UGHLEE *) + let data = + sprintf "Type: %s\nDistro: %s\nVersion: %d.%d\nArch.: %s\nPackaging: %s/%s\n%sMountpoints:\n%s" + os.Slave.insp_type os.Slave.insp_distro + os.Slave.insp_major_version os.Slave.insp_minor_version + os.Slave.insp_arch + os.Slave.insp_package_management os.Slave.insp_package_format + (match os.Slave.insp_windows_systemroot with + | None -> "" + | Some path -> + sprintf "%%systemroot%%: %s\n" (markup_escape path)) + (String.concat "\n" + (List.map ( + fun (mp, dev) -> + sprintf "%s on %s" + (markup_escape dev) (markup_escape mp)) + os.Slave.insp_mountpoints) + ) in + + model#set ~row ~column:t.name_col data + ) diff --git a/filetree_ops.mli b/filetree_ops.mli index 8b6e0e3..9191ad4 100644 --- a/filetree_ops.mli +++ b/filetree_ops.mli @@ -30,6 +30,8 @@ val disk_usage : Filetree_type.t -> Gtk.tree_path -> unit -> unit +val display_inspection_data : 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 diff --git a/filetree_type.ml b/filetree_type.ml index 9f2bc64..4b70b76 100644 --- a/filetree_type.ml +++ b/filetree_type.ml @@ -17,40 +17,39 @@ *) open Utils +open Printf +(* See struct/field description in .mli file. *) type t = { view : GTree.view; model : GTree.tree_store; - hash : (int, hdata) Hashtbl.t; (* hash from index_col -> hdata *) + 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; + size_col : string GTree.column; date_col : string GTree.column; - link_col : string GTree.column; } -and hdata = state_t * content_t +and hdata = { + mutable state : state_t; + content : content_t; + mutable visited : bool; +} -(* 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 *) + | IsLeaf + | NodeNotStarted + | NodeLoading + | IsNode -(* The actual content of a row. *) 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 *) + | Loading + | ErrorMessage of string + | Info of string + | Top of Slave.source + | Directory of Slave.direntry + | File of Slave.direntry (* Store hdata into a row. *) let store_hdata {model = model; hash = hash; index_col = index_col} row hdata = @@ -65,9 +64,9 @@ let get_hdata { model = model; hash = hash; index_col = index_col } row = 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 find_child_node_by_content ({ model = model } as t) row c = let rec loop row = - if hdata = get_hdata t row then + if (get_hdata t row).content = c then row else if model#iter_next row then loop row @@ -95,20 +94,104 @@ let rec get_pathname ({ model = model } as t) row = let parent = model#iter_parent row in match hdata, parent with - | (IsLeaf, (Loading|ErrorMessage _|Info _)), Some parent -> + | { state=IsLeaf; content=(Loading|ErrorMessage _|Info _) }, Some parent -> get_pathname t parent - | (IsLeaf, (Loading|ErrorMessage _|Info _)), None -> + | { state=IsLeaf; content=(Loading|ErrorMessage _|Info _) }, None -> assert false - | (_, Directory { Slave.dent_name = name }), Some parent - | (_, File { Slave.dent_name = name }), Some parent -> + | { content=Directory { Slave.dent_name = name }}, Some parent + | { content=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 - | (_, Info _), _ -> assert false + | { content=Top src }, _ -> src, "/" + | { content=Directory _}, None -> assert false + | { content=File _}, None -> assert false + | { content=Loading }, _ -> assert false + | { content=ErrorMessage _}, _ -> assert false + | { content=Info _}, _ -> assert false + +(* Base colours. XXX Should be configurable somewhere. *) +let file_color = 0x20, 0x20, 0xff (* regular file *) +let dir_color = 0x80, 0x80, 0x20 (* directory *) +let symlink_color = file_color (* symlink *) +let suid_color = 0x20, 0x20, 0x80 (* setuid bit set on regular file *) +let suid_bgcolor = 0xff, 0xc0, 0xc0 +let sgid_color = suid_color (* setgid bit set on regular file *) +let sgid_bgcolor = suid_bgcolor +let block_color = 0x00, 0x60, 0x60 (* block device *) +let char_color = block_color (* char device *) +let fifo_color = 0x60, 0x00, 0x60 (* fifo *) +let socket_color = fifo_color (* socket *) +let other_color = file_color (* anything not one of the above *) + +(* Mark up a filename for the name_col column. + * + * XXX This shouldn't be in Filetree_type module, but we have to have + * it here because set_visited is here. + * + * See also + * http://library.gnome.org/devel/pango/stable/PangoMarkupFormat.html + *) +let rec markup_of_name ?(visited = false) direntry = + let name = direntry.Slave.dent_name in + let mode = direntry.Slave.dent_stat.Guestfs.mode in + if is_directory mode then ( (* directory *) + let fg = if not visited then normal dir_color else darken dir_color in + sprintf "%s" + fg (markup_escape name) + ) + else if is_symlink mode then ( (* symlink *) + let link = direntry.Slave.dent_link in + let fg = + if not visited then normal symlink_color else darken symlink_color in + sprintf "%s %s %s" + fg (markup_escape name) utf8_rarrow fg (markup_escape link) + ) + else ( (* not directory, not symlink *) + let fg, bg = + if is_regular_file mode then ( + if is_suid mode then suid_color, Some suid_bgcolor + else if is_sgid mode then sgid_color, Some sgid_bgcolor + else file_color, None + ) + else if is_block mode then block_color, None + else if is_char mode then char_color, None + else if is_fifo mode then fifo_color, None + else if is_socket mode then socket_color, None + else other_color, None in + let fg = if not visited then normal fg else darken fg in + let bg = + match bg with + | Some bg -> sprintf " bgcolor=\"%s\"" (normal bg) + | None -> "" in + sprintf "%s" + fg bg (markup_escape name) + ) + +and normal (r, g, b) = + let r = if r < 0 then 0 else if r > 255 then 255 else r in + let g = if g < 0 then 0 else if g > 255 then 255 else g in + let b = if b < 0 then 0 else if b > 255 then 255 else b in + sprintf "#%02x%02x%02x" r g b + +and darken (r, g, b) = + normal (r * 4 / 10, g * 4 / 10, b * 4 / 10) + +(* This is a bit of a hack. Ideally just setting 'visited' would + * darken the colour when the cell was re-rendered. However that would + * mean we couldn't store other stuff in the name column. Therefore, + * repopulate the name column. + *) +let set_visited ({ model = model; name_col = name_col } as t) row = + let hdata = get_hdata t row in + if hdata.visited = false then ( + hdata.visited <- true; + match hdata.content with + | Directory direntry | File direntry -> + debug "set_visited %s" direntry.Slave.dent_name; + model#set ~row ~column:name_col + (markup_of_name ~visited:true direntry) + | Loading | ErrorMessage _ | Info _ | Top _ -> () + ) diff --git a/filetree_type.mli b/filetree_type.mli index 18a5187..590b635 100644 --- a/filetree_type.mli +++ b/filetree_type.mli @@ -28,41 +28,60 @@ type t = { view : GTree.view; model : GTree.tree_store; - hash : (int, hdata) Hashtbl.t; + 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; + size_col : string GTree.column; date_col : string GTree.column; - link_col : string GTree.column; } -and hdata = state_t * content_t +(* The internal data we store attached to each row, telling us about + * the state of the row and what is in it. + *) +and hdata = { + mutable state : state_t; + content : content_t; + mutable visited : bool; +} +(* 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 - | NodeNotStarted - | NodeLoading - | IsNode + | 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 - | ErrorMessage of string - | Info of string - | Top of Slave.source - | Directory of Slave.direntry - | File of Slave.direntry + | 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 *) 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 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 find_child_node_by_content : t -> Gtk.tree_iter -> content_t -> Gtk.tree_iter + (* [find_child_node_by_content t row content] searches the direct + children of [row] looking for one which exactly matches + [hdata.content] 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 markup_of_name : ?visited:bool -> Slave.direntry -> string + (* Create markup for filenames. *) + +val set_visited : t -> Gtk.tree_iter -> unit + (* Set a file as visited. *) diff --git a/utils.ml b/utils.ml index 8ad67c4..02bd7a0 100644 --- a/utils.ml +++ b/utils.ml @@ -16,6 +16,8 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open ExtString + open Printf let (+^) = Int64.add @@ -25,6 +27,8 @@ let (/^) = Int64.div type ('a, 'b) either = Left of 'a | Right of 'b +let (//) = Filename.concat + let verbose = ref false let set_verbose_flag () = verbose := true let verbose () = !verbose @@ -59,19 +63,39 @@ let connect_uri () = !connect_uri let utf8_rarrow = "\xe2\x86\x92" +let human_size i = + if i < 1024L then + sprintf "%Ld" i + else if i < 1024L *^ 1024L then + sprintf "%.1f KB" (Int64.to_float i /. 1024.) + else if i < 1024L *^ 1024L *^ 1024L then + sprintf "%.1f MB" (Int64.to_float i /. 1024. /. 1024.) + else if i < 1024L *^ 1024L *^ 1024L *^ 1024L then + sprintf "%.1f GB" (Int64.to_float i /. 1024. /. 1024. /. 1024.) + else + sprintf "%.1f TB" (Int64.to_float i /. 1024. /. 1024. /. 1024. /. 1024.) + let human_size_1k i = if i < 1024L then - sprintf "%LdK" i + sprintf "%Ld KB" i else if i < 1024L *^ 1024L then - sprintf "%.1fM" (Int64.to_float i /. 1024.) + sprintf "%.1f MB" (Int64.to_float i /. 1024.) else - sprintf "%.1fG" (Int64.to_float i /. 1024. /. 1024.) + sprintf "%.1f GB" (Int64.to_float i /. 1024. /. 1024.) let unique = let i = ref 0 in fun () -> incr i; !i let mklabel text = (GMisc.label ~text () :> GObj.widget) +(* XXX No binding for g_markup_escape in lablgtk2. *) +let markup_escape name = + let f = function + | '&' -> "&" | '<' -> "<" | '>' -> ">" + | c -> String.make 1 c + in + String.replace_chars f name + let libguestfs_version_string () = let g = new Guestfs.guestfs () in let v = g#version () in @@ -85,4 +109,33 @@ let libvirt_version_string () = let v = fst (Libvirt.get_version ()) in sprintf "%d.%d.%d" (v / 1_000_000) ((v / 1_000) mod 1_000) (v mod 1_000) -let (//) = Filename.concat +(* File type tests. + * + * Note these have to be on Linux ABI modes. We cannot use the + * OCaml (ie. host) equivalents here. + *) +let rec file_type mask mode = Int64.logand mode 0o170000L = mask + +and is_socket mode = file_type 0o140000L mode +and is_symlink mode = file_type 0o120000L mode +and is_regular_file mode = file_type 0o100000L mode +and is_block mode = file_type 0o060000L mode +and is_directory mode = file_type 0o040000L mode +and is_char mode = file_type 0o020000L mode +and is_fifo mode = file_type 0o010000L mode + +and is_suid mode = test_bit 0o4000L mode +and is_sgid mode = test_bit 0o2000L mode +and is_svtx mode = test_bit 0o1000L mode + +and is_ru mode = test_bit 0o400L mode +and is_wu mode = test_bit 0o200L mode +and is_xu mode = test_bit 0o100L mode +and is_rg mode = test_bit 0o040L mode +and is_wg mode = test_bit 0o020L mode +and is_xg mode = test_bit 0o010L mode +and is_ro mode = test_bit 0o004L mode +and is_wo mode = test_bit 0o002L mode +and is_xo mode = test_bit 0o001L mode + +and test_bit mask mode = Int64.logand mode mask = mask diff --git a/utils.mli b/utils.mli index 3e93755..1bc1669 100644 --- a/utils.mli +++ b/utils.mli @@ -28,6 +28,9 @@ type ('a, 'b) either = Left of 'a | Right of 'b (** A value which is either an ['a] or a ['b], just like Haskell's "Either" type. *) +val (//) : string -> string -> string + (** Concatenate two paths. *) + val verbose : unit -> bool val set_verbose_flag : unit -> unit (** If this contains [true] then {!debug} will send debugging @@ -57,8 +60,12 @@ val set_connect_uri : string option -> unit val utf8_rarrow : string (** UTF-8 RIGHTWARDS ARROW *) +val human_size : int64 -> string + (** Convert a number of bytes into a human readable string. *) + val human_size_1k : int64 -> string - (** Convert a number (of 1K blocks) into a human readable string. *) + (** Same as {!human_size} but the argument is 1KB blocks (used for + disk usage). *) val unique : unit -> int (** Return a new integer each time called. *) @@ -67,11 +74,36 @@ val mklabel : string -> GObj.widget (** Convenience function to make a label containing some text. It is returned as a generic widget. *) +val markup_escape : string -> string + (** Call g_markup_escape. *) + val libguestfs_version_string : unit -> string (** Return the version of libguestfs as a string. *) val libvirt_version_string : unit -> string (** Return the version of libvirt as a string. *) -val (//) : string -> string -> string - (** Concatenate two paths. *) +val is_socket : int64 -> bool +val is_symlink : int64 -> bool +val is_regular_file : int64 -> bool +val is_block : int64 -> bool +val is_directory : int64 -> bool +val is_char : int64 -> bool +val is_fifo : int64 -> bool + (** File type tests. *) + +val is_suid : int64 -> bool +val is_sgid : int64 -> bool +val is_svtx : int64 -> bool + (** File setuid, setgid, sticky bit tests. *) + +val is_ru : int64 -> bool +val is_wu : int64 -> bool +val is_xu : int64 -> bool +val is_rg : int64 -> bool +val is_wg : int64 -> bool +val is_xg : int64 -> bool +val is_ro : int64 -> bool +val is_wo : int64 -> bool +val is_xo : int64 -> bool + (** rwx/ugo bits. *) diff --git a/window.ml b/window.ml index ab52078..aa32625 100644 --- a/window.ml +++ b/window.ml @@ -27,6 +27,7 @@ type window_state = { window : GWindow.window; view : Filetree.t; vmcombo : GEdit.combo_box GEdit.text_combo; + refresh_button : GButton.button; throbber : GMisc.image; throbber_static : GdkPixbuf.pixbuf; statusbar : GMisc.statusbar; @@ -144,7 +145,7 @@ let rec open_main_window () = make_menubar window vbox ~packing:vbox#pack () in (* Top toolbar. *) - let vmcombo, throbber, throbber_static = + let vmcombo, refresh_button, throbber, throbber_static = make_toolbar ~packing:vbox#pack () in (* Main part of display is the file tree. *) @@ -164,6 +165,7 @@ let rec open_main_window () = window = window; view = view; vmcombo = vmcombo; + refresh_button = refresh_button; throbber = throbber; throbber_static = throbber_static; statusbar = statusbar; statusbar_context = statusbar_context; progress_bar = progress_bar @@ -181,7 +183,9 @@ let rec open_main_window () = ignore (connect_none_item#connect#activate ~callback:(fun () -> connect_to ws None)); - (* VM combo box when changed by the user. *) + (* VM combo box when changed by the user. + * The refresh button acts like changing the VM combo too. + *) let combo, (model, column) = ws.vmcombo in ignore ( combo#connect#changed @@ -192,6 +196,15 @@ let rec open_main_window () = | Some row -> open_domain ws (model#get ~row ~column) ) ); + ignore ( + refresh_button#connect#clicked + ~callback:( + fun () -> + match combo#active_iter with + | None -> () (* nothing selected *) + | Some row -> open_domain ws (model#get ~row ~column) + ) + ); (* Return the window_state struct. *) ws @@ -235,13 +248,22 @@ and make_toolbar ~packing () = hbox#pack (mklabel "Guest: "); let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in + (* Refresh button. + * http://stackoverflow.com/questions/2188659/stock-icons-not-shown-on-buttons + *) + let refresh_button = + let image = GMisc.image ~stock:`REFRESH () in + let b = GButton.button ~packing:hbox#pack () in + b#set_image (image :> GObj.widget); + b in + (* Throbber. *) let static = Throbber.static () in (*let animation = Throbber.animation () in*) let throbber = GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in - vmcombo, throbber, static + vmcombo, refresh_button, throbber, static and make_filetree ~packing () = let sw = -- 1.8.3.1