2 * Copyright (C) 2010 Red Hat Inc.
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License along
15 * with this program; if not, write to the Free Software Foundation, Inc.,
16 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
27 let unique = let i = ref 0 in fun () -> incr i; !i
29 (* The type of the hidden column used to implement on-demand loading.
30 * We are going to store these in the model as simple ints because that
31 * is easier on the GC. Don't change these numbers!
33 let isFile = 0 (* it's not a directory, there are no children *)
34 let dirNotStarted = 1 (* user has not tried to open this *)
35 let dirLoading = 2 (* user tried to open it, still loading *)
36 let isDir = 3 (* we've loaded the children of this directory *)
37 let loading = 4 (* this row contains the "Loading ..." message *)
39 let rec filetree dev rw =
40 let view = GTree.view () in
41 (*view#set_rules_hint true;*)
42 view#selection#set_mode `MULTIPLE;
44 (* Hash of index numbers -> other data. We do this because it's
45 * more efficient for the GC compared to storing OCaml objects
46 * directly in the rows.
48 let hash = Hashtbl.create 1023 in
50 (* The columns stored in each row. The hidden [state_col] column
51 * stores the current state of the row, and is used to implement
52 * on-demand loading. The hidden [index_col] column is an index into
53 * the hash table that records everything else about this row
54 * (filename, file stat, etc). The other display columns, eg.
55 * [name_col] contain Pango markup and thus have to be escaped.
57 let cols = new GTree.column_list in
59 let state_col = cols#add Gobject.Data.int in
60 let index_col = cols#add Gobject.Data.int in
62 let mode_col = cols#add Gobject.Data.string in
63 let name_col = cols#add Gobject.Data.string in
64 let size_col = cols#add Gobject.Data.int64 in
65 let date_col = cols#add Gobject.Data.string in
66 let link_col = cols#add Gobject.Data.string in
68 let model = GTree.tree_store cols in
69 view#set_model (Some (model :> GTree.model));
71 let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
72 let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
73 ignore (view#append_column mode_view);
75 let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
76 let name_view = GTree.view_column ~title:"Filename" ~renderer () in
77 ignore (view#append_column name_view);
79 let renderer = GTree.cell_renderer_text [], ["text", size_col] in
80 let size_view = GTree.view_column ~title:"Size" ~renderer () in
81 ignore (view#append_column size_view);
83 let renderer = GTree.cell_renderer_text [], ["markup", date_col] in
84 let date_view = GTree.view_column ~title:"Date" ~renderer () in
85 ignore (view#append_column date_view);
87 let renderer = GTree.cell_renderer_text [], ["markup", link_col] in
88 let link_view = GTree.view_column ~title:"Link" ~renderer () in
89 ignore (view#append_column link_view);
92 model, view, hash, dev, rw,
93 (state_col, index_col, mode_col, name_col, size_col, date_col,
96 (* Create the root directory entry, then expand it which will force
97 * it to be loaded (asynchronously).
100 let root = model#append () in
101 add_directory_row tree root "/" None;
102 view#expand_row (model#get_path root);
104 ignore (view#event#connect#button_press ~callback:(button_press tree));
105 (*ignore (view#event#connect#popup_menu ~callback);*)
109 (* Add an "embryonic" directory to the tree store. This contains a
110 * dummy entry (as explained
111 * http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html)
112 * and when the user opens it, it triggers the real directory to be
115 and add_directory_row tree row filename direntry =
116 let model, view, hash, _, _,
117 (state_col, index_col, mode_col, name_col, size_col, date_col,
121 model#set ~row ~column:state_col dirNotStarted;
122 model#set ~row ~column:index_col (-1);
123 model#set ~row ~column:name_col (markup_of_name filename);
127 let index = unique () in
128 Hashtbl.add hash index direntry;
129 model#set ~row ~column:index_col index;
130 let stat = direntry.Slave.dent_stat in
131 model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
132 model#set ~row ~column:size_col stat.G.size;
133 model#set ~row ~column:date_col (markup_of_date stat.G.mtime));
135 let placeholder = model#append ~parent:row () in
136 model#set ~row:placeholder ~column:state_col loading;
137 model#set ~row:placeholder ~column:index_col (-1);
138 model#set ~row:placeholder ~column:name_col "<i>Loading ...</i>";
139 ignore (view#connect#row_expanded ~callback:(expand_row tree))
141 (* This is called when the user expands the [directory] row. *)
142 and expand_row tree row _ =
143 let model, _, _, dev, _, (state_col, _, _, _, _, _, _) = tree in
145 match model#get ~row ~column:state_col with
146 | 1 (* dirNotStarted *) -> (* Kick off a directory read. *)
147 (* Get a stable path for this row so we can use it inside
148 * the callback, which may happen a lot later.
150 let path = model#get_path row in
152 (* Now invoke libguestfs in the slave thread. *)
154 dev (get_pathname tree row) (read_directory_cb tree path);
156 (* Mark this row as now loading, so we don't start another
157 * directory read if the user expands it again.
159 model#set ~row ~column:state_col dirLoading
161 | 0 (* isFile *) | 2 (* dirLoading *) | 3 (* isDir *) -> ()
162 | 4 (* loading *) -> assert false
165 and read_directory_cb tree path entries =
166 let model, _, hash, _, _,
167 (state_col, index_col, mode_col, name_col, size_col, date_col,
171 let row = model#get_iter path in
173 (* Add the entries. *)
176 let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
178 let row = model#append ~parent:row () in
179 if is_directory stat.G.mode then
180 add_directory_row tree row name (Some direntry)
182 let index = unique () in
183 Hashtbl.add hash index direntry;
184 model#set ~row ~column:state_col isFile;
185 model#set ~row ~column:index_col index;
186 model#set ~row ~column:name_col (markup_of_name name);
187 model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
188 model#set ~row ~column:size_col stat.G.size;
189 model#set ~row ~column:date_col (markup_of_date stat.G.mtime);
190 model#set ~row ~column:link_col (markup_of_link link)
194 (* Remove the placeholder entry. NB. Must be done AFTER adding
195 * the other entries, or else Gtk will unexpand the row.
198 let placeholder = model#iter_children ~nth:0 (Some row) in
199 ignore (model#remove placeholder)
200 with Invalid_argument _ -> ());
202 (* The original directory entry has now been loaded, so
205 model#set ~row ~column:state_col isDir
207 (* Get the actual full pathname of a row. *)
208 and get_pathname tree row =
209 let model, _, _, _, _, _ = tree in
211 match model#iter_parent row with
214 match get_direntry_of_row tree row with
215 | Some { Slave.dent_name = name } ->
216 let pname = get_pathname tree parent in
217 if pname = "/" then "/" ^ name else pname ^ "/" ^ name
221 (* Get the directory entry from a row (contains the stat(2) results etc).
222 * Some rows don't have the required information (eg. placeholder rows
223 * and currently the root directory) and for them we return [None].
225 and get_direntry_of_row tree row =
226 let model, _, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
227 let index = model#get ~row ~column:index_col in
228 try Some (Hashtbl.find hash index)
229 with Not_found -> None
231 (* XXX No binding for g_markup_escape in lablgtk2. *)
232 and markup_escape name =
234 | '&' -> "&" | '<' -> "<" | '>' -> ">"
235 | c -> String.make 1 c
237 String.replace_chars f name
239 (* Mark up a filename for the name_col column. *)
240 and markup_of_name name =
241 (* First, protect against any markup in the name. *)
242 let name = markup_escape name in
245 (* Mark up symbolic links. *)
246 and markup_of_link link =
247 let link = markup_escape link in
248 if link <> "" then utf8_rarrow ^ " " ^ link else ""
251 and markup_of_mode mode =
253 if is_socket mode then 's'
254 else if is_symlink mode then 'l'
255 else if is_regular_file mode then '-'
256 else if is_block mode then 'b'
257 else if is_directory mode then 'd'
258 else if is_char mode then 'c'
259 else if is_fifo mode then 'p' else '?' in
260 let ru = if test_bit 0o400L mode then 'r' else '-' in
261 let wu = if test_bit 0o200L mode then 'w' else '-' in
262 let xu = if test_bit 0o100L mode then 'x' else '-' in
263 let rg = if test_bit 0o40L mode then 'r' else '-' in
264 let wg = if test_bit 0o20L mode then 'w' else '-' in
265 let xg = if test_bit 0o10L mode then 'x' else '-' in
266 let ro = if test_bit 0o4L mode then 'r' else '-' in
267 let wo = if test_bit 0o2L mode then 'w' else '-' in
268 let xo = if test_bit 0o1L mode then 'x' else '-' in
269 let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
271 let suid = test_bit 0o4000L mode in
272 let sgid = test_bit 0o2000L mode in
273 let svtx = test_bit 0o1000L mode in
274 if suid then str.[3] <- 's';
275 if sgid then str.[6] <- 's';
276 if svtx then str.[9] <- 't';
278 "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
280 (* File type tests. *)
281 and file_type mask mode = Int64.logand mode 0o170000L = mask
283 and is_socket mode = file_type 0o140000L mode
284 and is_symlink mode = file_type 0o120000L mode
285 and is_regular_file mode = file_type 0o100000L mode
286 and is_block mode = file_type 0o060000L mode
287 and is_directory mode = file_type 0o040000L mode
288 and is_char mode = file_type 0o020000L mode
289 and is_fifo mode = file_type 0o010000L mode
291 and test_bit mask mode = Int64.logand mode mask = mask
294 and markup_of_date time =
295 let time = Int64.to_float time in
296 let tm = Unix.localtime time in
297 sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
298 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
299 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
301 (* Handle mouse button press on the selected row. This opens the
302 * pop-up context menu.
303 * http://scentric.net/tutorial/sec-selections-context-menus.html
305 and button_press tree ev =
306 let button = GdkEvent.Button.button ev in
307 let x = int_of_float (GdkEvent.Button.x ev) in
308 let y = int_of_float (GdkEvent.Button.y ev) in
309 let time = GdkEvent.Button.time ev in
311 (* Right button for opening the context menu. *)
313 let model, view, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
315 (* If no row is selected, select the row under the mouse. *)
317 let sel = view#selection in
318 if sel#count_selected_rows < 1 then (
319 match view#get_path_at_pos ~x ~y with
321 | Some (path, _, _, _) ->
323 sel#select_path path;
326 sel#get_selected_rows (* actually returns paths *) in
328 (* Ignore paths that don't contain index fields, and get the
329 * direntry for the others. Currently this causes the root
330 * directory to be ignored because we don't have stat information
336 let row = model#get_iter path in
337 match get_direntry_of_row tree row with
339 | Some direntry -> Some (path, direntry)
342 (* Choose the menu and menu options according to the number of
343 * selected rows and what is selected.
349 | [path, direntry] -> (* Single selection. *)
350 (* What object is selected? *)
351 let stat = direntry.Slave.dent_stat in
352 let mode = stat.G.mode in
353 if is_directory mode then
354 Some (make_context_menu tree ~dir:true ~file:false paths)
355 else if is_regular_file mode then
356 Some (make_context_menu tree ~dir:false ~file:true paths)
357 else (* not directory, not regular file *)
358 Some (make_context_menu tree ~dir:false ~file:false paths)
359 | paths -> (* Multiple selection. *)
360 let dir = List.for_all (
361 fun (_, { Slave.dent_stat = stat }) ->
362 is_directory stat.G.mode
364 let file = List.for_all (
365 fun (_, { Slave.dent_stat = stat }) ->
366 is_regular_file stat.G.mode
368 Some (make_context_menu tree ~dir ~file paths)
370 with Not_found -> None
375 menu#popup ~button ~time;
378 (* Return true so no other handler will run. *)
381 (* Defer to other handlers. *)
384 (* Make a context menu for file(s) and directory(s). ~file is true is
385 * they are all regular files, ~dir is true if they are all
386 * directories. If neither is set, then it can be a single selection
387 * of a non-file non-directory, or it can be a mixed multiple
390 and make_context_menu tree ~dir ~file paths =
391 let _, _, _, _, rw, _ = tree in
392 let n = List.length paths in
393 assert (n > 0); (* calling code ensures this *)
394 let path0 = List.hd paths in
396 let menu = GMenu.menu () in
397 let factory = new GMenu.factory menu in
399 (* Open appears first, and unconditionally. This is just to catch
400 * the case where nothing below matches, and we want to display
401 * _something_. Open is not necessarily useful ...
403 ignore (factory#add_item "Open");
404 ignore (factory#add_separator ());
406 if dir && n = 1 then (
407 let item = factory#add_item "Disk _usage ..." in
408 ignore (item#connect#activate ~callback:(disk_usage_dialog tree path0));
409 let item = factory#add_item "_Export as an archive (tar etc) ..." in
410 ignore (item#connect#activate ~callback:(export_archive_dialog tree path0));
411 let item = factory#add_item "Export _checksums ..." in
412 ignore (item#connect#activate
413 ~callback:(export_checksums_dialog tree path0));
414 let item = factory#add_item "Export as a _list of files ..." in
415 ignore (item#connect#activate ~callback:(export_list_dialog tree path0));
419 ignore (factory#add_item "Determine file type ...");
422 ignore (factory#add_item "View permissions ...");
424 (* Write operations go below the separator. *)
428 ignore (factory#add_separator ());
430 if dir && n = 1 then (
431 ignore (factory#add_item "New file ...");
432 ignore (factory#add_item "New subdirectory ...");
433 ignore (factory#add_item "Import an archive here ...");
437 ignore (factory#add_item "Touch file");
438 ignore (factory#add_item "Edit file");
442 ignore (factory#add_item "Edit permissions ...");
444 ignore (factory#add_item "Delete")
449 (* The disk usage dialog. *)
450 and disk_usage_dialog tree path0 () =
451 let model, _, _, dev, _,_ = tree in
452 let row = model#get_iter (fst path0) in
453 let dir = get_pathname tree row in
455 (* We can't use GWindow.message_dialog since lablgtk2 doesn't expose
456 * the label field. It wouldn't help very much anyway.
458 let title = "Calculating disk usage ..." in
459 let dlg = GWindow.dialog ~title ~modal:true () in
461 sprintf "Calculating disk usage of %s ... This may take a moment." dir in
462 let label = GMisc.label ~text ~packing:dlg#vbox#pack () in
463 dlg#add_button "Stop" `STOP;
464 dlg#add_button "Close" `DELETE_EVENT;
465 let close_button, stop_button =
466 match dlg#action_area#children with
468 | _ -> assert false in
469 close_button#misc#set_sensitive false;
471 let callback = function
472 | `STOP -> debug "STOP response" (* XXX NOT IMPL XXX *)
473 | `DELETE_EVENT -> debug "DELETE_EVENT response"; dlg#destroy ()
475 ignore (dlg#connect#response ~callback);
477 Slave.disk_usage dev dir (
478 fun kbytes -> (* Called when operation has finished. *)
479 dlg#set_title "Disk usage";
480 label#set_text (sprintf "Disk usage of %s: %Ld KB" dir kbytes);
481 close_button#misc#set_sensitive true;
482 stop_button#misc#set_sensitive false
485 (* NB. We cannot use dlg#run. See:
486 * http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/600.txt
487 * Therefore this function just exits back to the ordinary main loop.
491 and export_archive_dialog tree path0 () =
492 (* XXX NOT IMPL XXX *)
495 and export_checksums_dialog tree path0 () =
496 (* XXX NOT IMPL XXX *)
499 and export_list_dialog tree path0 () =
500 (* XXX NOT IMPL XXX *)
503 and do_export_dialog tree path0 t =
504 (* XXX NOT IMPL XXX *)