*)
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 =
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
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 "<span weight=\"bold\" fgcolor=\"%s\">%s</span>"
+ 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 "<span style=\"italic\" fgcolor=\"%s\">%s</span> %s <span style=\"italic\" fgcolor=\"%s\">%s</span>"
+ 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 "<span fgcolor=\"%s\"%s>%s</span>"
+ 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 _ -> ()
+ )
git.annexia.org / guestfs-browser.git / blobdiff