(* 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 ExtList
open ExtString
open Printf
open Utils
module G = Guestfs
(* The type of the hidden column used to implement on-demand loading.
* We are going to store these in the model as simple ints because that
* is easier on the GC. Don't change these numbers!
*)
let isFile = 0 (* it's not a directory, there are no children *)
let dirNotStarted = 1 (* user has not tried to open this *)
let dirLoading = 2 (* user tried to open it, still loading *)
let isDir = 3 (* we've loaded the children of this directory *)
let loading = 4 (* this row contains the "Loading ..." message *)
let rec filetree dev rw =
let view = GTree.view () in
(*view#set_rules_hint true;*)
view#selection#set_mode `MULTIPLE;
(* Hash of index numbers -> other data. We do this because it's
* more efficient for the GC compared to storing OCaml objects
* directly in the rows.
*)
let hash = Hashtbl.create 1023 in
(* The columns stored in each row. The hidden [state_col] column
* stores the current state of the row, and is used to implement
* on-demand loading. The hidden [index_col] column is an index into
* the hash table that records everything else about this row
* (filename, file stat, etc). The other display columns, eg.
* [name_col] contain Pango markup and thus have to be escaped.
*)
let cols = new GTree.column_list in
(* Hidden: *)
let state_col = cols#add Gobject.Data.int in
let index_col = cols#add Gobject.Data.int in
(* 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 date_col = cols#add Gobject.Data.string in
let link_col = cols#add Gobject.Data.string in
let model = GTree.tree_store cols in
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
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
ignore (view#append_column name_view);
let renderer = GTree.cell_renderer_text [], ["text", size_col] in
let size_view = GTree.view_column ~title:"Size" ~renderer () in
ignore (view#append_column size_view);
let renderer = GTree.cell_renderer_text [], ["markup", date_col] in
let date_view = GTree.view_column ~title:"Date" ~renderer () in
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 tree =
model, view, hash, dev, rw,
(state_col, index_col, mode_col, name_col, size_col, date_col,
link_col) in
(* Create the root directory entry, then expand it which will force
* it to be loaded (asynchronously).
* XXX Should stat "/"
*)
let root = model#append () in
add_directory_row tree root "/" None;
view#expand_row (model#get_path root);
ignore (view#event#connect#button_press ~callback:(button_press tree));
(*ignore (view#event#connect#popup_menu ~callback);*)
view
(* Add an "embryonic" directory to the tree store. This contains a
* dummy entry (as explained
* http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html)
* and when the user opens it, it triggers the real directory to be
* read.
*)
and add_directory_row tree row filename direntry =
let model, view, hash, _, _,
(state_col, index_col, mode_col, name_col, size_col, date_col,
link_col)
= tree in
model#set ~row ~column:state_col dirNotStarted;
model#set ~row ~column:index_col (-1);
model#set ~row ~column:name_col (markup_of_name filename);
(match direntry with
| None -> ()
| Some direntry ->
let index = unique () in
Hashtbl.add hash index direntry;
model#set ~row ~column:index_col index;
let stat = direntry.Slave.dent_stat in
model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
model#set ~row ~column:size_col stat.G.size;
model#set ~row ~column:date_col (markup_of_date stat.G.mtime));
let placeholder = model#append ~parent:row () in
model#set ~row:placeholder ~column:state_col loading;
model#set ~row:placeholder ~column:index_col (-1);
model#set ~row:placeholder ~column:name_col "Loading ...";
ignore (view#connect#row_expanded ~callback:(expand_row tree))
(* This is called when the user expands the [directory] row. *)
and expand_row tree row _ =
let model, _, _, dev, _, (state_col, _, _, _, _, _, _) = tree in
match model#get ~row ~column:state_col with
| 1 (* dirNotStarted *) -> (* Kick off a directory read. *)
(* Get a stable path for this row so we can use it inside
* the callback, which may happen a lot later.
*)
let path = model#get_path row in
(* Now invoke libguestfs in the slave thread. *)
Slave.read_directory
dev (get_pathname tree row) (read_directory_cb tree path);
(* Mark this row as now loading, so we don't start another
* directory read if the user expands it again.
*)
model#set ~row ~column:state_col dirLoading
| 0 (* isFile *) | 2 (* dirLoading *) | 3 (* isDir *) -> ()
| 4 (* loading *) -> assert false
| _ -> assert false
and read_directory_cb tree path entries =
let model, _, hash, _, _,
(state_col, index_col, mode_col, name_col, size_col, date_col,
link_col)
= tree in
let row = model#get_iter path in
(* Add the entries. *)
List.iter (
fun direntry ->
let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
direntry in
let row = model#append ~parent:row () in
if is_directory stat.G.mode then
add_directory_row tree row name (Some direntry)
else (
let index = unique () in
Hashtbl.add hash index direntry;
model#set ~row ~column:state_col isFile;
model#set ~row ~column:index_col index;
model#set ~row ~column:name_col (markup_of_name name);
model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
model#set ~row ~column:size_col stat.G.size;
model#set ~row ~column:date_col (markup_of_date stat.G.mtime);
model#set ~row ~column:link_col (markup_of_link link)
)
) entries;
(* Remove the placeholder entry. NB. Must be done AFTER adding
* the other entries, or else Gtk will unexpand the row.
*)
(try
let placeholder = model#iter_children ~nth:0 (Some row) in
ignore (model#remove placeholder)
with Invalid_argument _ -> ());
(* The original directory entry has now been loaded, so
* update its state.
*)
model#set ~row ~column:state_col isDir
(* Get the actual full pathname of a row. *)
and get_pathname tree row =
let model, _, _, _, _, _ = tree in
match model#iter_parent row with
| None -> "/"
| Some parent ->
match get_direntry_of_row tree row with
| Some { Slave.dent_name = name } ->
let pname = get_pathname tree parent in
if pname = "/" then "/" ^ name else pname ^ "/" ^ name
| None ->
assert false
(* Get the directory entry from a row (contains the stat(2) results etc).
* Some rows don't have the required information (eg. placeholder rows
* and currently the root directory) and for them we return [None].
*)
and get_direntry_of_row tree row =
let model, _, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
let index = model#get ~row ~column:index_col in
try Some (Hashtbl.find hash index)
with Not_found -> None
(* XXX No binding for g_markup_escape in lablgtk2. *)
and 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. *)
and markup_of_name name =
(* First, protect against any markup in the name. *)
let name = markup_escape name in
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 c =
if is_socket mode then 's'
else if is_symlink mode then 'l'
else if is_regular_file mode then '-'
else if is_block mode then 'b'
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 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
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
and test_bit mask mode = Int64.logand mode mask = mask
(* 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
(* 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 tree 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 (
let model, view, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
(* 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
(* Ignore paths that don't contain index fields, and get the
* direntry for the others. Currently this causes the root
* directory to be ignored because we don't have stat information
* for it (XXX).
*)
let paths =
List.filter_map (
fun path ->
let row = model#get_iter path in
match get_direntry_of_row tree row with
| None -> None
| Some direntry -> Some (path, direntry)
) paths in
(* Choose the menu and menu options according to the number of
* selected rows and what is selected.
*)
let menu =
try
(match paths with
| [] -> None
| [path, direntry] -> (* Single selection. *)
(* What object is selected? *)
let stat = direntry.Slave.dent_stat in
let mode = stat.G.mode in
if is_directory mode then
Some (make_context_menu tree ~dir:true ~file:false paths)
else if is_regular_file mode then
Some (make_context_menu tree ~dir:false ~file:true paths)
else (* not directory, not regular file *)
Some (make_context_menu tree ~dir:false ~file:false paths)
| paths -> (* Multiple selection. *)
let dir = List.for_all (
fun (_, { Slave.dent_stat = stat }) ->
is_directory stat.G.mode
) paths in
let file = List.for_all (
fun (_, { Slave.dent_stat = stat }) ->
is_regular_file stat.G.mode
) paths in
Some (make_context_menu tree ~dir ~file paths)
)
with Not_found -> None
in
(match menu with
| None -> ()
| Some menu ->
menu#popup ~button ~time;
);
(* Return true so no other handler will run. *)
true
) else
(* Defer to other handlers. *)
false
(* Make a context menu for file(s) and directory(s). ~file is true is
* they are all regular files, ~dir is true if they are all
* directories. If neither is set, then it can be a single selection
* of a non-file non-directory, or it can be a mixed multiple
* selection.
*)
and make_context_menu tree ~dir ~file paths =
let _, _, _, _, rw, _ = tree in
let n = List.length paths in
assert (n > 0); (* calling code ensures this *)
let path0 = List.hd paths in
let menu = GMenu.menu () in
let factory = new GMenu.factory menu in
(* Open appears first, and unconditionally. This is just to catch
* the case where nothing below matches, and we want to display
* _something_. Open is not necessarily useful ...
*)
ignore (factory#add_item "Open");
ignore (factory#add_separator ());
if dir && n = 1 then (
let item = factory#add_item "Disk _usage ..." in
ignore (item#connect#activate ~callback:(disk_usage_dialog tree path0));
let item = factory#add_item "_Export as an archive (tar etc) ..." in
ignore (item#connect#activate ~callback:(export_archive_dialog tree path0));
let item = factory#add_item "Export _checksums ..." in
ignore (item#connect#activate
~callback:(export_checksums_dialog tree path0));
let item = factory#add_item "Export as a _list of files ..." in
ignore (item#connect#activate ~callback:(export_list_dialog tree path0));
);
if file then
ignore (factory#add_item "Determine file type ...");
if n = 1 then
ignore (factory#add_item "View permissions ...");
(* Write operations go below the separator. *)
(match rw with
| Slave.RO -> ()
| Slave.RW ->
ignore (factory#add_separator ());
if dir && n = 1 then (
ignore (factory#add_item "New file ...");
ignore (factory#add_item "New subdirectory ...");
ignore (factory#add_item "Import an archive here ...");
);
if file then (
ignore (factory#add_item "Touch file");
ignore (factory#add_item "Edit file");
);
if n = 1 then
ignore (factory#add_item "Edit permissions ...");
ignore (factory#add_item "Delete")
);
menu
(* The disk usage dialog. *)
and disk_usage_dialog tree path0 () =
let model, _, _, dev, _,_ = tree in
let row = model#get_iter (fst path0) in
let dir = get_pathname tree row in
(* We can't use GWindow.message_dialog since lablgtk2 doesn't expose
* the label field. It wouldn't help very much anyway.
*)
let title = "Calculating disk usage ..." in
let dlg = GWindow.dialog ~title ~modal:true () in
let text =
sprintf "Calculating disk usage of %s ... This may take a moment." dir in
let label = GMisc.label ~text ~packing:dlg#vbox#pack () in
dlg#add_button "Stop" `STOP;
dlg#add_button "Close" `DELETE_EVENT;
let close_button, stop_button =
match dlg#action_area#children with
| c::s::_ -> c, s
| _ -> assert false in
close_button#misc#set_sensitive false;
let callback = function
| `STOP -> debug "STOP response" (* XXX NOT IMPL XXX *)
| `DELETE_EVENT -> debug "DELETE_EVENT response"; dlg#destroy ()
in
ignore (dlg#connect#response ~callback);
Slave.disk_usage dev dir (
fun kbytes -> (* Called when operation has finished. *)
dlg#set_title "Disk usage";
label#set_text (sprintf "Disk usage of %s: %Ld KB" dir kbytes);
close_button#misc#set_sensitive true;
stop_button#misc#set_sensitive false
);
(* NB. We cannot use dlg#run. See:
* http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/600.txt
* Therefore this function just exits back to the ordinary main loop.
*)
dlg#show ()
and export_archive_dialog tree path0 () =
(* XXX NOT IMPL XXX *)
(* let model, _, _, dev, _,_ = tree in
let row = model#get_iter (fst path0) in
let dir = get_pathname tree row in*)
let title = "Choose output file" in
let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
(* Allow the user to select the output format. *)
let strings = ["tar.gz (compressed)"; "tar (uncompressed)"] in
let combo, _ = GEdit.combo_box_text ~strings ~active:0 () in
dlg#set_extra_widget (combo :> GObj.widget);
dlg#show ()
and export_checksums_dialog tree path0 () =
(* XXX NOT IMPL XXX *)
(* let model, _, _, dev, _,_ = tree in
let row = model#get_iter (fst path0) in
let dir = get_pathname tree row in*)
let title = "Choose output file" in
let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
(* Allow the user to select the output algorithm. *)
let strings =
["crc"; "md5"; "sha1"; "sha224"; "sha256"; "sha384"; "sha512"] in
let combo, _ = GEdit.combo_box_text ~strings ~active:1 () in
dlg#set_extra_widget (combo :> GObj.widget);
dlg#show ()
and export_list_dialog tree path0 () =
(* XXX NOT IMPL XXX *)
(* let model, _, _, dev, _,_ = tree in
let row = model#get_iter (fst path0) in
let dir = get_pathname tree row in*)
let title = "Choose output file" in
let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
(* Notify that the list of strings is \0 separated. *)
let hbox =
let hbox = GPack.hbox () in
ignore (GMisc.image ~stock:`INFO ~packing:hbox#pack ());
let label = GMisc.label ~text:"The list of filenames is saved to a file with zero byte separators, to allow the full range of characters to be used in the names themselves." ~packing:hbox#pack () in
label#set_line_wrap true;
hbox in
dlg#set_extra_widget (hbox :> GObj.widget);
dlg#show ()
and do_export_dialog tree path0 t =
(* XXX NOT IMPL XXX *)
()