(* 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
open Printf
(* See struct/field description in .mli file. *)
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 : string GTree.column;
date_col : string GTree.column;
}
and hdata = {
mutable state : state_t;
content : content_t;
mutable visited : bool;
}
and state_t =
| IsLeaf
| NodeNotStarted
| NodeLoading
| IsNode
and content_t =
| 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 =
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
(* Iterate over children of node, looking for matching hdata. *)
let find_child_node_by_content ({ model = model } as t) row c =
let rec loop row =
if (get_hdata t row).content = c then
row
else if model#iter_next row then
loop row
else
raise Not_found
in
if not (model#iter_has_child row) then
raise Not_found;
let first_child = model#iter_children (Some row) in
loop first_child
(* Search up to the top of the tree so we know if this directory
* comes from an OS or a volume, and the full path to here.
*
* 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
| { state=IsLeaf; content=(Loading|ErrorMessage _|Info _) }, Some parent ->
get_pathname t parent
| { state=IsLeaf; content=(Loading|ErrorMessage _|Info _) }, None ->
assert false
| { 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
| { 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 _ -> ()
)