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])
open ExtString
open ExtList
+open Unix
open Printf
open Utils
(* 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. *)
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
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
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
(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
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'
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';
"<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
-(* 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 "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
+ (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 "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
- (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
+ "<small>now</small>"
+ else if ago < 60. *. 60. then
+ sprintf "<small>%.0f minutes ago</small>" (ago /. 60.)
+ else if ago < 60. *. 60. *. 24. then
+ sprintf "<small>%.0f hours ago</small>" (ago /. 60. /. 60.)
+ else if ago < 60. *. 60. *. 24. *. 28. then
+ sprintf "<small>%.0f days ago</small>" (ago /. 60. /. 60. /. 24.)
+ else
+ show_full_date ()
+
+(* Mark up file sizes. *)
+let markup_of_size bytes =
+ sprintf "<small>%s</small>" (human_size bytes)
let clear { model = model; hash = hash } =
model#clear ();
(* 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 "<i>Loading ...</i>";
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
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
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 =
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 -> ()
);
(* 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
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)
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 () =
(* 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
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. *)
(* 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 "<i>Calculating disk usage ...</i>";
- 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 "<b>Disk usage: %Ld KB</b>" kbytes in
+ let content = Info "disk_usage" in
+ let row = find_child_node_by_content t row content in
+ let msg =
+ sprintf "<b>%s</b>\n<small>Disk usage of %s (%Ld KB)</small>"
+ (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: <b>%s</b>\nDistro: <b>%s</b>\nVersion: <b>%d.%d</b>\nArch.: <b>%s</b>\nPackaging: <b>%s</b>/<b>%s</b>\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%%: <b>%s</b>\n" (markup_escape path))
+ (String.concat "\n"
+ (List.map (
+ fun (mp, dev) ->
+ sprintf "<b>%s</b> on <b>%s</b>"
+ (markup_escape dev) (markup_escape mp))
+ os.Slave.insp_mountpoints)
+ ) in
+
+ model#set ~row ~column:t.name_col data
+ )
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
*)
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 _ -> ()
+ )
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. *)
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
+open ExtString
+
open Printf
let (+^) = Int64.add
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
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
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
(** 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
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. *)
(** 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. *)
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;
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. *)
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
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
| 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
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 =
git.annexia.org / guestfs-browser.git / commitdiff