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.
31 type t = Filetree_type.t
33 let rec create ~packing () =
34 let view = GTree.view ~packing () in
35 (*view#set_rules_hint true;*)
36 (*view#selection#set_mode `MULTIPLE; -- add this later *)
38 (* Hash of index numbers -> hdata. We do this because it's more
39 * efficient for the GC compared to storing OCaml objects directly in
42 let hash = Hashtbl.create 1023 in
44 (* The columns stored in each row. The hidden [index_col] column is
45 * an index into the hash table that records everything else about
46 * this row (see hdata above). The other display columns, eg.
47 * [name_col] contain Pango markup and thus have to be escaped.
49 let cols = new GTree.column_list in
51 let index_col = cols#add Gobject.Data.int in
53 let mode_col = cols#add Gobject.Data.string in
54 let name_col = cols#add Gobject.Data.string in
55 let size_col = cols#add Gobject.Data.int64 in
56 let date_col = cols#add Gobject.Data.string in
57 let link_col = cols#add Gobject.Data.string in
59 (* Create the model. *)
60 let model = GTree.tree_store cols in
61 view#set_model (Some (model :> GTree.model));
63 let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
64 let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
65 ignore (view#append_column mode_view);
67 let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
68 let name_view = GTree.view_column ~title:"Filename" ~renderer () in
69 name_view#set_max_width 300 (*pixels?!?*);
70 ignore (view#append_column name_view);
72 let renderer = GTree.cell_renderer_text [], ["text", size_col] in
73 let size_view = GTree.view_column ~title:"Size" ~renderer () in
74 ignore (view#append_column size_view);
76 let renderer = GTree.cell_renderer_text [], ["markup", date_col] in
77 let date_view = GTree.view_column ~title:"Date" ~renderer () in
78 ignore (view#append_column date_view);
80 let renderer = GTree.cell_renderer_text [], ["markup", link_col] in
81 let link_view = GTree.view_column ~title:"Link" ~renderer () in
82 ignore (view#append_column link_view);
85 view = view; model = model; hash = hash;
86 index_col = index_col;
87 mode_col = mode_col; name_col = name_col; size_col = size_col;
88 date_col = date_col; link_col = link_col;
91 (* Open a context menu when a button is pressed. *)
92 ignore (view#event#connect#button_press ~callback:(button_press t));
96 (* Handle mouse button press on the selected row. This opens the
97 * pop-up context menu.
98 * http://scentric.net/tutorial/sec-selections-context-menus.html
100 and button_press ({ model = model; view = view } as t) ev =
101 let button = GdkEvent.Button.button ev in
102 let x = int_of_float (GdkEvent.Button.x ev) in
103 let y = int_of_float (GdkEvent.Button.y ev) in
104 let time = GdkEvent.Button.time ev in
106 (* Right button for opening the context menu. *)
109 (* If no row is selected, select the row under the mouse. *)
111 let sel = view#selection in
112 if sel#count_selected_rows < 1 then (
113 match view#get_path_at_pos ~x ~y with
115 | Some (path, _, _, _) ->
117 sel#select_path path;
120 sel#get_selected_rows (* actually returns paths *) in
122 (* Select the row under the mouse. *)
124 let sel = view#selection in
125 match view#get_path_at_pos ~x ~y with
127 | Some (path, _, _, _) ->
129 sel#select_path path;
132 (* Get the hdata for all the paths. Filter out rows that it doesn't
133 * make sense to select.
138 let row = model#get_iter path in
139 let hdata = get_hdata t row in
141 | _, (Loading | ErrorMessage _ | Info _) -> None
142 | _, (Top _ | Directory _ | File _) -> Some (path, hdata)
145 (* Based on number of selected rows and what is selected, construct
148 if paths <> [] then (
149 let menu = make_context_menu t paths in
150 menu#popup ~button ~time
153 (* Return true so no other handler will run. *)
156 (* We didn't handle this, defer to other handlers. *)
159 and make_context_menu t paths =
160 let menu = GMenu.menu () in
161 let factory = new GMenu.factory menu in
163 let item = factory#add_item "Open" in
164 item#misc#set_sensitive false;
166 let rec add_file_items path =
167 let item = factory#add_item "File information" in
168 item#misc#set_sensitive false;
169 let item = factory#add_item "Checksum" in
170 item#misc#set_sensitive false;
171 ignore (factory#add_separator ());
172 let item = factory#add_item "Download ..." in
173 ignore (item#connect#activate ~callback:(download_file t path));
175 and add_directory_items path =
176 let item = factory#add_item "Directory information" in
177 item#misc#set_sensitive false;
178 let item = factory#add_item "Space used by directory" in
179 ignore (item#connect#activate ~callback:(disk_usage t path));
180 ignore (factory#add_separator ());
181 let item = factory#add_item "Download ..." in
182 item#misc#set_sensitive false;
183 let item = factory#add_item "Download as .tar ..." in
184 ignore (item#connect#activate
185 ~callback:(download_dir_tarball t Slave.Tar path));
186 let item = factory#add_item "Download as .tar.gz ..." in
187 ignore (item#connect#activate
188 ~callback:(download_dir_tarball t Slave.TGZ path));
189 let item = factory#add_item "Download as .tar.xz ..." in
190 ignore (item#connect#activate
191 ~callback:(download_dir_tarball t Slave.TXZ path));
192 let item = factory#add_item "Download list of filenames ..." in
193 ignore (item#connect#activate ~callback:(download_dir_find0 t path));
195 and add_os_items path =
196 let item = factory#add_item "Operating system information" in
197 item#misc#set_sensitive false;
198 let item = factory#add_item "Block device information" in
199 item#misc#set_sensitive false;
200 let item = factory#add_item "Filesystem used & free" in
201 item#misc#set_sensitive false;
202 ignore (factory#add_separator ());
203 add_directory_items path
205 and add_volume_items path =
206 let item = factory#add_item "Filesystem used & free" in
207 item#misc#set_sensitive false;
208 let item = factory#add_item "Block device information" in
209 item#misc#set_sensitive false;
210 ignore (factory#add_separator ());
211 add_directory_items path
215 (* single selection *)
216 | [path, (_, Top (Slave.OS os))] -> (* top level operating system *)
219 | [path, (_, Top (Slave.Volume dev))] -> (* top level volume *)
220 add_volume_items path
222 | [path, (_, Directory direntry)] -> (* directory *)
223 add_directory_items path
225 | [path, (_, File direntry)] -> (* file *)
229 | [_, (_, ErrorMessage _)] -> ()
232 (* At the moment multiple selection is disabled. When/if we
233 * enable it we should do something intelligent here. XXX
240 (* XXX No binding for g_markup_escape in lablgtk2. *)
241 let markup_escape name =
243 | '&' -> "&" | '<' -> "<" | '>' -> ">"
244 | c -> String.make 1 c
246 String.replace_chars f name
248 (* Mark up a filename for the name_col column. *)
249 let rec markup_of_name name =
252 (* Mark up symbolic links. *)
253 and markup_of_link link =
254 let link = markup_escape link in
255 if link <> "" then utf8_rarrow ^ " " ^ link else ""
258 and markup_of_mode mode =
260 if is_socket mode then 's'
261 else if is_symlink mode then 'l'
262 else if is_regular_file mode then '-'
263 else if is_block mode then 'b'
264 else if is_directory mode then 'd'
265 else if is_char mode then 'c'
266 else if is_fifo mode then 'p' else '?' in
267 let ru = if test_bit 0o400L mode then 'r' else '-' in
268 let wu = if test_bit 0o200L mode then 'w' else '-' in
269 let xu = if test_bit 0o100L mode then 'x' else '-' in
270 let rg = if test_bit 0o40L mode then 'r' else '-' in
271 let wg = if test_bit 0o20L mode then 'w' else '-' in
272 let xg = if test_bit 0o10L mode then 'x' else '-' in
273 let ro = if test_bit 0o4L mode then 'r' else '-' in
274 let wo = if test_bit 0o2L mode then 'w' else '-' in
275 let xo = if test_bit 0o1L mode then 'x' else '-' in
276 let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
278 let suid = test_bit 0o4000L mode in
279 let sgid = test_bit 0o2000L mode in
280 let svtx = test_bit 0o1000L mode in
281 if suid then str.[3] <- 's';
282 if sgid then str.[6] <- 's';
283 if svtx then str.[9] <- 't';
285 "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
287 (* File type tests. *)
288 and file_type mask mode = Int64.logand mode 0o170000L = mask
290 and is_socket mode = file_type 0o140000L mode
291 and is_symlink mode = file_type 0o120000L mode
292 and is_regular_file mode = file_type 0o100000L mode
293 and is_block mode = file_type 0o060000L mode
294 and is_directory mode = file_type 0o040000L mode
295 and is_char mode = file_type 0o020000L mode
296 and is_fifo mode = file_type 0o010000L mode
298 and test_bit mask mode = Int64.logand mode mask = mask
301 and markup_of_date time =
302 let time = Int64.to_float time in
303 let tm = Unix.localtime time in
304 sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
305 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
306 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
308 let clear { model = model; hash = hash } =
312 let rec add ({ model = model; hash = hash } as t) name data =
315 (* Populate the top level of the filetree. If there are operating
316 * systems from inspection, these have their own top level entries
317 * followed by only unreferenced filesystems. If we didn't get
318 * anything from inspection, then at the top level we just show
321 let other_filesystems =
322 DeviceSet.of_list (List.map fst data.Slave.insp_all_filesystems) in
323 let other_filesystems =
324 List.fold_left (fun set { Slave.insp_filesystems = fses } ->
325 DeviceSet.subtract set (DeviceSet.of_array fses))
326 other_filesystems data.Slave.insp_oses in
328 (* Add top level operating systems. *)
329 List.iter (add_top_level_os t name) data.Slave.insp_oses;
331 (* Add top level left-over filesystems. *)
332 DeviceSet.iter (add_top_level_vol t name) other_filesystems;
334 (* Expand the first top level node. *)
335 match model#get_iter_first with
338 t.view#expand_row (model#get_path row)
340 and add_top_level_os ({ model = model; hash = hash } as t) name os =
342 sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
343 (markup_escape name) (markup_escape os.Slave.insp_hostname)
344 (markup_escape os.Slave.insp_product_name) in
346 let row = model#append () in
347 make_node t row (Top (Slave.OS os));
348 model#set ~row ~column:t.name_col markup
350 and add_top_level_vol ({ model = model; hash = hash } as t) name dev =
352 sprintf "<b>%s</b>\n<small>from %s</small>"
353 (markup_escape dev) (markup_escape name) in
355 let row = model#append () in
356 make_node t row (Top (Slave.Volume dev));
357 model#set ~row ~column:t.name_col markup
359 (* Generic function to make an openable node to the tree. *)
360 and make_node ({ model = model; hash = hash } as t) row content =
361 let hdata = NodeNotStarted, content in
362 store_hdata t row hdata;
364 (* Create a placeholder "loading ..." row underneath this node so
365 * the user has something to expand.
367 let placeholder = model#append ~parent:row () in
368 let hdata = IsLeaf, Loading in
369 store_hdata t placeholder hdata;
370 model#set ~row:placeholder ~column:t.name_col "<i>Loading ...</i>";
371 ignore (t.view#connect#row_expanded ~callback:(expand_row t))
373 and make_leaf ({ model = model; hash = hash } as t) row content =
374 let hdata = IsLeaf, content in
375 store_hdata t row hdata
377 (* This is called when the user expands a row. *)
378 and expand_row ({ model = model; hash = hash } as t) row _ =
379 match get_hdata t row with
380 | NodeNotStarted, Top src ->
381 (* User has opened a top level node that was not previously opened. *)
383 (* Mark this row as loading, so we don't try to open it again. *)
384 let hdata = NodeLoading, Top src in
385 store_hdata t row hdata;
387 (* Get a stable path for this row. *)
388 let path = model#get_path row in
390 Slave.read_directory ~fail:(when_read_directory_fail t path)
391 src "/" (when_read_directory t path)
393 | NodeNotStarted, Directory direntry ->
394 (* User has opened a filesystem directory not previously opened. *)
396 (* Mark this row as loading. *)
397 let hdata = NodeLoading, Directory direntry in
398 store_hdata t row hdata;
400 (* Get a stable path for this row. *)
401 let path = model#get_path row in
403 let src, pathname = get_pathname t row in
405 Slave.read_directory ~fail:(when_read_directory_fail t path)
406 src pathname (when_read_directory t path)
408 | NodeLoading, _ | IsNode, _ -> ()
410 (* These are not nodes so it should never be possible to open them. *)
411 | _, File _ | IsLeaf, _ -> assert false
413 (* Node should not exist in the tree. *)
414 | NodeNotStarted, (Loading | ErrorMessage _ | Info _) -> assert false
416 (* This is the callback when the slave has read the directory for us. *)
417 and when_read_directory ({ model = model } as t) path entries =
418 debug "when_read_directory";
420 let row = model#get_iter path in
422 (* Add the entries. *)
425 let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
427 let row = model#append ~parent:row () in
428 if is_directory stat.G.mode then
429 make_node t row (Directory direntry)
431 make_leaf t row (File direntry);
432 model#set ~row ~column:t.name_col (markup_of_name name);
433 model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode);
434 model#set ~row ~column:t.size_col stat.G.size;
435 model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime);
436 model#set ~row ~column:t.link_col (markup_of_link link)
439 (* Remove the placeholder "Loading" entry. NB. Must be done AFTER
440 * adding the other entries, or else Gtk will unexpand the row.
443 let hdata = IsLeaf, Loading in
444 let row = find_child_node_by_hdata t row hdata in
445 ignore (model#remove row)
446 with Invalid_argument _ | Not_found -> ()
449 (* The original directory entry has now been loaded, so
452 let state, content = get_hdata t row in
453 let hdata = IsNode, content in
454 store_hdata t row hdata
456 (* This is called instead of when_read_directory when the read directory
457 * (or mount etc) failed. Convert the "Loading" entry into the
460 and when_read_directory_fail ({ model = model } as t) path exn =
461 debug "when_read_directory_fail: %s" (Printexc.to_string exn);
465 let row = model#get_iter path in
466 let row = model#iter_children ~nth:0 (Some row) in
468 let hdata = IsLeaf, ErrorMessage msg in
469 store_hdata t row hdata;
471 model#set ~row ~column:t.name_col (markup_escape msg)
474 (* unexpected exception: re-raise it *)