X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=filetree.ml;fp=filetree.ml;h=1969cc76939db8fd76a99269754a4e407193f9bb;hb=b07102fda0034da5840a9f33bd6d404a195b8cc9;hp=0000000000000000000000000000000000000000;hpb=bbfe03c47f1d7f03c3e6c0cab9e4f500f588c80a;p=guestfs-browser.git
diff --git a/filetree.ml b/filetree.ml
new file mode 100644
index 0000000..1969cc7
--- /dev/null
+++ b/filetree.ml
@@ -0,0 +1,442 @@
+(* 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
+
+let unique = let i = ref 0 in fun () -> incr i; !i
+
+(* 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
+
+ debug "make_context_menu dir %b file %b n %d" dir file n;
+
+ 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 (
+ ignore (factory#add_item "Disk usage ...");
+ ignore (factory#add_item "Export as an archive (tar etc) ...");
+ ignore (factory#add_item "Export checksums ...");
+ ignore (factory#add_item "Export as a list of files ...");
+ );
+
+ 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