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 (* The type of the hidden column used to implement on-demand loading.
28 * We are going to store these in the model as simple ints because that
29 * is easier on the GC. Don't change these numbers!
31 let isFile = 0 (* it's not a directory, there are no children *)
32 let dirNotStarted = 1 (* user has not tried to open this *)
33 let dirLoading = 2 (* user tried to open it, still loading *)
34 let isDir = 3 (* we've loaded the children of this directory *)
35 let loading = 4 (* this row contains the "Loading ..." message *)
37 let rec filetree dev rw =
38 let view = GTree.view () in
39 (*view#set_rules_hint true;*)
40 view#selection#set_mode `MULTIPLE;
42 (* Hash of index numbers -> other data. We do this because it's
43 * more efficient for the GC compared to storing OCaml objects
44 * directly in the rows.
46 let hash = Hashtbl.create 1023 in
48 (* The columns stored in each row. The hidden [state_col] column
49 * stores the current state of the row, and is used to implement
50 * on-demand loading. The hidden [index_col] column is an index into
51 * the hash table that records everything else about this row
52 * (filename, file stat, etc). The other display columns, eg.
53 * [name_col] contain Pango markup and thus have to be escaped.
55 let cols = new GTree.column_list in
57 let state_col = cols#add Gobject.Data.int in
58 let index_col = cols#add Gobject.Data.int in
60 let mode_col = cols#add Gobject.Data.string in
61 let name_col = cols#add Gobject.Data.string in
62 let size_col = cols#add Gobject.Data.int64 in
63 let date_col = cols#add Gobject.Data.string in
64 let link_col = cols#add Gobject.Data.string in
66 let model = GTree.tree_store cols in
67 view#set_model (Some (model :> GTree.model));
69 let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
70 let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
71 ignore (view#append_column mode_view);
73 let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
74 let name_view = GTree.view_column ~title:"Filename" ~renderer () in
75 ignore (view#append_column name_view);
77 let renderer = GTree.cell_renderer_text [], ["text", size_col] in
78 let size_view = GTree.view_column ~title:"Size" ~renderer () in
79 ignore (view#append_column size_view);
81 let renderer = GTree.cell_renderer_text [], ["markup", date_col] in
82 let date_view = GTree.view_column ~title:"Date" ~renderer () in
83 ignore (view#append_column date_view);
85 let renderer = GTree.cell_renderer_text [], ["markup", link_col] in
86 let link_view = GTree.view_column ~title:"Link" ~renderer () in
87 ignore (view#append_column link_view);
90 model, view, hash, dev, rw,
91 (state_col, index_col, mode_col, name_col, size_col, date_col,
94 (* Create the root directory entry, then expand it which will force
95 * it to be loaded (asynchronously).
98 let root = model#append () in
99 add_directory_row tree root "/" None;
100 view#expand_row (model#get_path root);
102 ignore (view#event#connect#button_press ~callback:(button_press tree));
103 (*ignore (view#event#connect#popup_menu ~callback);*)
107 (* Add an "embryonic" directory to the tree store. This contains a
108 * dummy entry (as explained
109 * http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html)
110 * and when the user opens it, it triggers the real directory to be
113 and add_directory_row tree row filename direntry =
114 let model, view, hash, _, _,
115 (state_col, index_col, mode_col, name_col, size_col, date_col,
119 model#set ~row ~column:state_col dirNotStarted;
120 model#set ~row ~column:index_col (-1);
121 model#set ~row ~column:name_col (markup_of_name filename);
125 let index = unique () in
126 Hashtbl.add hash index direntry;
127 model#set ~row ~column:index_col index;
128 let stat = direntry.Slave.dent_stat in
129 model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
130 model#set ~row ~column:size_col stat.G.size;
131 model#set ~row ~column:date_col (markup_of_date stat.G.mtime));
133 let placeholder = model#append ~parent:row () in
134 model#set ~row:placeholder ~column:state_col loading;
135 model#set ~row:placeholder ~column:index_col (-1);
136 model#set ~row:placeholder ~column:name_col "<i>Loading ...</i>";
137 ignore (view#connect#row_expanded ~callback:(expand_row tree))
139 (* This is called when the user expands the [directory] row. *)
140 and expand_row tree row _ =
141 let model, _, _, dev, _, (state_col, _, _, _, _, _, _) = tree in
143 match model#get ~row ~column:state_col with
144 | 1 (* dirNotStarted *) -> (* Kick off a directory read. *)
145 (* Get a stable path for this row so we can use it inside
146 * the callback, which may happen a lot later.
148 let path = model#get_path row in
150 (* Now invoke libguestfs in the slave thread. *)
152 dev (get_pathname tree row) (read_directory_cb tree path);
154 (* Mark this row as now loading, so we don't start another
155 * directory read if the user expands it again.
157 model#set ~row ~column:state_col dirLoading
159 | 0 (* isFile *) | 2 (* dirLoading *) | 3 (* isDir *) -> ()
160 | 4 (* loading *) -> assert false
163 and read_directory_cb tree path entries =
164 let model, _, hash, _, _,
165 (state_col, index_col, mode_col, name_col, size_col, date_col,
169 let row = model#get_iter path in
171 (* Add the entries. *)
174 let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
176 let row = model#append ~parent:row () in
177 if is_directory stat.G.mode then
178 add_directory_row tree row name (Some direntry)
180 let index = unique () in
181 Hashtbl.add hash index direntry;
182 model#set ~row ~column:state_col isFile;
183 model#set ~row ~column:index_col index;
184 model#set ~row ~column:name_col (markup_of_name name);
185 model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
186 model#set ~row ~column:size_col stat.G.size;
187 model#set ~row ~column:date_col (markup_of_date stat.G.mtime);
188 model#set ~row ~column:link_col (markup_of_link link)
192 (* Remove the placeholder entry. NB. Must be done AFTER adding
193 * the other entries, or else Gtk will unexpand the row.
196 let placeholder = model#iter_children ~nth:0 (Some row) in
197 ignore (model#remove placeholder)
198 with Invalid_argument _ -> ());
200 (* The original directory entry has now been loaded, so
203 model#set ~row ~column:state_col isDir
205 (* Get the actual full pathname of a row. *)
206 and get_pathname tree row =
207 let model, _, _, _, _, _ = tree in
209 match model#iter_parent row with
212 match get_direntry_of_row tree row with
213 | Some { Slave.dent_name = name } ->
214 let pname = get_pathname tree parent in
215 if pname = "/" then "/" ^ name else pname ^ "/" ^ name
219 (* Get the directory entry from a row (contains the stat(2) results etc).
220 * Some rows don't have the required information (eg. placeholder rows
221 * and currently the root directory) and for them we return [None].
223 and get_direntry_of_row tree row =
224 let model, _, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
225 let index = model#get ~row ~column:index_col in
226 try Some (Hashtbl.find hash index)
227 with Not_found -> None
229 (* XXX No binding for g_markup_escape in lablgtk2. *)
230 and markup_escape name =
232 | '&' -> "&" | '<' -> "<" | '>' -> ">"
233 | c -> String.make 1 c
235 String.replace_chars f name
237 (* Mark up a filename for the name_col column. *)
238 and markup_of_name name =
239 (* First, protect against any markup in the name. *)
240 let name = markup_escape name in
243 (* Mark up symbolic links. *)
244 and markup_of_link link =
245 let link = markup_escape link in
246 if link <> "" then utf8_rarrow ^ " " ^ link else ""
249 and markup_of_mode mode =
251 if is_socket mode then 's'
252 else if is_symlink mode then 'l'
253 else if is_regular_file mode then '-'
254 else if is_block mode then 'b'
255 else if is_directory mode then 'd'
256 else if is_char mode then 'c'
257 else if is_fifo mode then 'p' else '?' in
258 let ru = if test_bit 0o400L mode then 'r' else '-' in
259 let wu = if test_bit 0o200L mode then 'w' else '-' in
260 let xu = if test_bit 0o100L mode then 'x' else '-' in
261 let rg = if test_bit 0o40L mode then 'r' else '-' in
262 let wg = if test_bit 0o20L mode then 'w' else '-' in
263 let xg = if test_bit 0o10L mode then 'x' else '-' in
264 let ro = if test_bit 0o4L mode then 'r' else '-' in
265 let wo = if test_bit 0o2L mode then 'w' else '-' in
266 let xo = if test_bit 0o1L mode then 'x' else '-' in
267 let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
269 let suid = test_bit 0o4000L mode in
270 let sgid = test_bit 0o2000L mode in
271 let svtx = test_bit 0o1000L mode in
272 if suid then str.[3] <- 's';
273 if sgid then str.[6] <- 's';
274 if svtx then str.[9] <- 't';
276 "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
278 (* File type tests. *)
279 and file_type mask mode = Int64.logand mode 0o170000L = mask
281 and is_socket mode = file_type 0o140000L mode
282 and is_symlink mode = file_type 0o120000L mode
283 and is_regular_file mode = file_type 0o100000L mode
284 and is_block mode = file_type 0o060000L mode
285 and is_directory mode = file_type 0o040000L mode
286 and is_char mode = file_type 0o020000L mode
287 and is_fifo mode = file_type 0o010000L mode
289 and test_bit mask mode = Int64.logand mode mask = mask
292 and markup_of_date time =
293 let time = Int64.to_float time in
294 let tm = Unix.localtime time in
295 sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
296 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
297 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
299 (* Handle mouse button press on the selected row. This opens the
300 * pop-up context menu.
301 * http://scentric.net/tutorial/sec-selections-context-menus.html
303 and button_press tree ev =
304 let button = GdkEvent.Button.button ev in
305 let x = int_of_float (GdkEvent.Button.x ev) in
306 let y = int_of_float (GdkEvent.Button.y ev) in
307 let time = GdkEvent.Button.time ev in
309 (* Right button for opening the context menu. *)
311 let model, view, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
313 (* If no row is selected, select the row under the mouse. *)
315 let sel = view#selection in
316 if sel#count_selected_rows < 1 then (
317 match view#get_path_at_pos ~x ~y with
319 | Some (path, _, _, _) ->
321 sel#select_path path;
324 sel#get_selected_rows (* actually returns paths *) in
326 (* Ignore paths that don't contain index fields, and get the
327 * direntry for the others. Currently this causes the root
328 * directory to be ignored because we don't have stat information
334 let row = model#get_iter path in
335 match get_direntry_of_row tree row with
337 | Some direntry -> Some (path, direntry)
340 (* Choose the menu and menu options according to the number of
341 * selected rows and what is selected.
347 | [path, direntry] -> (* Single selection. *)
348 (* What object is selected? *)
349 let stat = direntry.Slave.dent_stat in
350 let mode = stat.G.mode in
351 if is_directory mode then
352 Some (make_context_menu tree ~dir:true ~file:false paths)
353 else if is_regular_file mode then
354 Some (make_context_menu tree ~dir:false ~file:true paths)
355 else (* not directory, not regular file *)
356 Some (make_context_menu tree ~dir:false ~file:false paths)
357 | paths -> (* Multiple selection. *)
358 let dir = List.for_all (
359 fun (_, { Slave.dent_stat = stat }) ->
360 is_directory stat.G.mode
362 let file = List.for_all (
363 fun (_, { Slave.dent_stat = stat }) ->
364 is_regular_file stat.G.mode
366 Some (make_context_menu tree ~dir ~file paths)
368 with Not_found -> None
373 menu#popup ~button ~time;
376 (* Return true so no other handler will run. *)
379 (* Defer to other handlers. *)
382 (* Make a context menu for file(s) and directory(s). ~file is true is
383 * they are all regular files, ~dir is true if they are all
384 * directories. If neither is set, then it can be a single selection
385 * of a non-file non-directory, or it can be a mixed multiple
388 and make_context_menu tree ~dir ~file paths =
389 let _, _, _, _, rw, _ = tree in
390 let n = List.length paths in
391 assert (n > 0); (* calling code ensures this *)
392 let path0 = List.hd paths in
394 let menu = GMenu.menu () in
395 let factory = new GMenu.factory menu in
397 (* Open appears first, and unconditionally. This is just to catch
398 * the case where nothing below matches, and we want to display
399 * _something_. Open is not necessarily useful ...
401 ignore (factory#add_item "Open");
402 ignore (factory#add_separator ());
404 if dir && n = 1 then (
405 let item = factory#add_item "Disk _usage ..." in
406 ignore (item#connect#activate ~callback:(disk_usage_dialog tree path0));
407 let item = factory#add_item "_Export as an archive (tar etc) ..." in
408 ignore (item#connect#activate ~callback:(export_archive_dialog tree path0));
409 let item = factory#add_item "Export _checksums ..." in
410 ignore (item#connect#activate
411 ~callback:(export_checksums_dialog tree path0));
412 let item = factory#add_item "Export as a _list of files ..." in
413 ignore (item#connect#activate ~callback:(export_list_dialog tree path0));
417 ignore (factory#add_item "Determine file type ...");
420 ignore (factory#add_item "View permissions ...");
422 (* Write operations go below the separator. *)
426 ignore (factory#add_separator ());
428 if dir && n = 1 then (
429 ignore (factory#add_item "New file ...");
430 ignore (factory#add_item "New subdirectory ...");
431 ignore (factory#add_item "Import an archive here ...");
435 ignore (factory#add_item "Touch file");
436 ignore (factory#add_item "Edit file");
440 ignore (factory#add_item "Edit permissions ...");
442 ignore (factory#add_item "Delete")
447 (* The disk usage dialog. *)
448 and disk_usage_dialog tree path0 () =
449 let model, _, _, dev, _,_ = tree in
450 let row = model#get_iter (fst path0) in
451 let dir = get_pathname tree row in
453 (* We can't use GWindow.message_dialog since lablgtk2 doesn't expose
454 * the label field. It wouldn't help very much anyway.
456 let title = "Calculating disk usage ..." in
457 let dlg = GWindow.dialog ~title ~modal:true () in
459 sprintf "Calculating disk usage of %s ... This may take a moment." dir in
460 let label = GMisc.label ~text ~packing:dlg#vbox#pack () in
461 dlg#add_button "Stop" `STOP;
462 dlg#add_button "Close" `DELETE_EVENT;
463 let close_button, stop_button =
464 match dlg#action_area#children with
466 | _ -> assert false in
467 close_button#misc#set_sensitive false;
469 let callback = function
470 | `STOP -> debug "STOP response" (* XXX NOT IMPL XXX *)
471 | `DELETE_EVENT -> debug "DELETE_EVENT response"; dlg#destroy ()
473 ignore (dlg#connect#response ~callback);
475 Slave.disk_usage dev dir (
476 fun kbytes -> (* Called when operation has finished. *)
477 dlg#set_title "Disk usage";
478 label#set_text (sprintf "Disk usage of %s: %Ld KB" dir kbytes);
479 close_button#misc#set_sensitive true;
480 stop_button#misc#set_sensitive false
483 (* NB. We cannot use dlg#run. See:
484 * http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/600.txt
485 * Therefore this function just exits back to the ordinary main loop.
489 and export_archive_dialog tree path0 () =
490 (* XXX NOT IMPL XXX *)
491 (* let model, _, _, dev, _,_ = tree in
492 let row = model#get_iter (fst path0) in
493 let dir = get_pathname tree row in*)
495 let title = "Choose output file" in
496 let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
498 (* Allow the user to select the output format. *)
499 let strings = ["tar.gz (compressed)"; "tar (uncompressed)"] in
500 let combo, _ = GEdit.combo_box_text ~strings ~active:0 () in
501 dlg#set_extra_widget (combo :> GObj.widget);
505 and export_checksums_dialog tree path0 () =
506 (* XXX NOT IMPL XXX *)
507 (* let model, _, _, dev, _,_ = tree in
508 let row = model#get_iter (fst path0) in
509 let dir = get_pathname tree row in*)
511 let title = "Choose output file" in
512 let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
514 (* Allow the user to select the output algorithm. *)
516 ["crc"; "md5"; "sha1"; "sha224"; "sha256"; "sha384"; "sha512"] in
517 let combo, _ = GEdit.combo_box_text ~strings ~active:1 () in
518 dlg#set_extra_widget (combo :> GObj.widget);
522 and export_list_dialog tree path0 () =
523 (* XXX NOT IMPL XXX *)
524 (* let model, _, _, dev, _,_ = tree in
525 let row = model#get_iter (fst path0) in
526 let dir = get_pathname tree row in*)
528 let title = "Choose output file" in
529 let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
531 (* Notify that the list of strings is \0 separated. *)
533 let hbox = GPack.hbox () in
534 ignore (GMisc.image ~stock:`INFO ~packing:hbox#pack ());
535 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
536 label#set_line_wrap true;
538 dlg#set_extra_widget (hbox :> GObj.widget);
542 and do_export_dialog tree path0 t =
543 (* XXX NOT IMPL XXX *)