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 ?status ~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;
92 (* Open a context menu when a button is pressed. *)
93 ignore (view#event#connect#button_press ~callback:(button_press t));
97 (* Handle mouse button press on the selected row. This opens the
98 * pop-up context menu.
99 * http://scentric.net/tutorial/sec-selections-context-menus.html
101 and button_press ({ model = model; view = view } as t) ev =
102 let button = GdkEvent.Button.button ev in
103 let x = int_of_float (GdkEvent.Button.x ev) in
104 let y = int_of_float (GdkEvent.Button.y ev) in
105 let time = GdkEvent.Button.time ev in
107 (* Right button for opening the context menu. *)
110 (* If no row is selected, select the row under the mouse. *)
112 let sel = view#selection in
113 if sel#count_selected_rows < 1 then (
114 match view#get_path_at_pos ~x ~y with
116 | Some (path, _, _, _) ->
118 sel#select_path path;
121 sel#get_selected_rows (* actually returns paths *) in
123 (* Select the row under the mouse. *)
125 let sel = view#selection in
126 match view#get_path_at_pos ~x ~y with
128 | Some (path, _, _, _) ->
130 sel#select_path path;
133 (* Get the hdata for all the paths. Filter out rows that it doesn't
134 * make sense to select.
139 let row = model#get_iter path in
140 let hdata = get_hdata t row in
142 | _, (Loading | ErrorMessage _) -> None
143 | _, (Top _ | Directory _ | File _) -> Some (path, hdata)
146 (* Based on number of selected rows and what is selected, construct
149 if paths <> [] then (
150 let menu = make_context_menu t paths in
151 menu#popup ~button ~time
154 (* Return true so no other handler will run. *)
157 (* We didn't handle this, defer to other handlers. *)
160 and make_context_menu t paths =
161 let menu = GMenu.menu () in
162 let factory = new GMenu.factory menu in
164 let item = factory#add_item "Open" in
165 item#misc#set_sensitive false;
167 let rec add_file_items path =
168 let item = factory#add_item "File information" in
169 item#misc#set_sensitive false;
170 let item = factory#add_item "Checksum" in
171 item#misc#set_sensitive false;
172 ignore (factory#add_separator ());
173 let item = factory#add_item "Download ..." in
174 ignore (item#connect#activate ~callback:(download_file t path));
176 and add_directory_items path =
177 let item = factory#add_item "Directory information" in
178 item#misc#set_sensitive false;
179 let item = factory#add_item "Space used by directory" in
180 item#misc#set_sensitive false;
181 ignore (factory#add_separator ());
182 let item = factory#add_item "Download ..." in
183 item#misc#set_sensitive false;
184 let item = factory#add_item "Download as .tar ..." in
185 ignore (item#connect#activate
186 ~callback:(download_dir_tarball t Slave.Tar path));
187 let item = factory#add_item "Download as .tar.gz ..." in
188 ignore (item#connect#activate
189 ~callback:(download_dir_tarball t Slave.TGZ path));
190 let item = factory#add_item "Download as .tar.xz ..." in
191 ignore (item#connect#activate
192 ~callback:(download_dir_tarball t Slave.TXZ path));
193 let item = factory#add_item "Download list of filenames ..." in
194 ignore (item#connect#activate ~callback:(download_dir_find0 t path));
196 and add_os_items path =
197 let item = factory#add_item "Operating system information" in
198 item#misc#set_sensitive false;
199 let item = factory#add_item "Block device information" in
200 item#misc#set_sensitive false;
201 let item = factory#add_item "Filesystem used & free" in
202 item#misc#set_sensitive false;
203 ignore (factory#add_separator ());
204 add_directory_items path
206 and add_volume_items path =
207 let item = factory#add_item "Filesystem used & free" in
208 item#misc#set_sensitive false;
209 let item = factory#add_item "Block device information" in
210 item#misc#set_sensitive false;
211 ignore (factory#add_separator ());
212 add_directory_items path
216 (* single selection *)
217 | [path, (_, Top (Slave.OS os))] -> (* top level operating system *)
220 | [path, (_, Top (Slave.Volume dev))] -> (* top level volume *)
221 add_volume_items path
223 | [path, (_, Directory direntry)] -> (* directory *)
224 add_directory_items path
226 | [path, (_, File direntry)] -> (* file *)
230 | [_, (_, ErrorMessage _)] -> ()
233 (* At the moment multiple selection is disabled. When/if we
234 * enable it we should do something intelligent here. XXX
241 (* XXX No binding for g_markup_escape in lablgtk2. *)
242 let markup_escape name =
244 | '&' -> "&" | '<' -> "<" | '>' -> ">"
245 | c -> String.make 1 c
247 String.replace_chars f name
249 (* Mark up a filename for the name_col column. *)
250 let rec markup_of_name name =
253 (* Mark up symbolic links. *)
254 and markup_of_link link =
255 let link = markup_escape link in
256 if link <> "" then utf8_rarrow ^ " " ^ link else ""
259 and markup_of_mode mode =
261 if is_socket mode then 's'
262 else if is_symlink mode then 'l'
263 else if is_regular_file mode then '-'
264 else if is_block mode then 'b'
265 else if is_directory mode then 'd'
266 else if is_char mode then 'c'
267 else if is_fifo mode then 'p' else '?' in
268 let ru = if test_bit 0o400L mode then 'r' else '-' in
269 let wu = if test_bit 0o200L mode then 'w' else '-' in
270 let xu = if test_bit 0o100L mode then 'x' else '-' in
271 let rg = if test_bit 0o40L mode then 'r' else '-' in
272 let wg = if test_bit 0o20L mode then 'w' else '-' in
273 let xg = if test_bit 0o10L mode then 'x' else '-' in
274 let ro = if test_bit 0o4L mode then 'r' else '-' in
275 let wo = if test_bit 0o2L mode then 'w' else '-' in
276 let xo = if test_bit 0o1L mode then 'x' else '-' in
277 let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
279 let suid = test_bit 0o4000L mode in
280 let sgid = test_bit 0o2000L mode in
281 let svtx = test_bit 0o1000L mode in
282 if suid then str.[3] <- 's';
283 if sgid then str.[6] <- 's';
284 if svtx then str.[9] <- 't';
286 "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
288 (* File type tests. *)
289 and file_type mask mode = Int64.logand mode 0o170000L = mask
291 and is_socket mode = file_type 0o140000L mode
292 and is_symlink mode = file_type 0o120000L mode
293 and is_regular_file mode = file_type 0o100000L mode
294 and is_block mode = file_type 0o060000L mode
295 and is_directory mode = file_type 0o040000L mode
296 and is_char mode = file_type 0o020000L mode
297 and is_fifo mode = file_type 0o010000L mode
299 and test_bit mask mode = Int64.logand mode mask = mask
302 and markup_of_date time =
303 let time = Int64.to_float time in
304 let tm = Unix.localtime time in
305 sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
306 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
307 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
309 let clear { model = model; hash = hash } =
313 let rec add ({ model = model; hash = hash } as t) name data =
316 (* Populate the top level of the filetree. If there are operating
317 * systems from inspection, these have their own top level entries
318 * followed by only unreferenced filesystems. If we didn't get
319 * anything from inspection, then at the top level we just show
322 let other_filesystems =
323 DeviceSet.of_list (List.map fst data.Slave.insp_all_filesystems) in
324 let other_filesystems =
325 List.fold_left (fun set { Slave.insp_filesystems = fses } ->
326 DeviceSet.subtract set (DeviceSet.of_array fses))
327 other_filesystems data.Slave.insp_oses in
329 (* Add top level operating systems. *)
330 List.iter (add_top_level_os t name) data.Slave.insp_oses;
332 (* Add top level left-over filesystems. *)
333 DeviceSet.iter (add_top_level_vol t name) other_filesystems;
335 (* Expand the first top level node. *)
336 match model#get_iter_first with
339 t.view#expand_row (model#get_path row)
341 and add_top_level_os ({ model = model; hash = hash } as t) name os =
343 sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
344 (markup_escape name) (markup_escape os.Slave.insp_hostname)
345 (markup_escape os.Slave.insp_product_name) in
347 let row = model#append () in
348 make_node t row (Top (Slave.OS os));
349 model#set ~row ~column:t.name_col markup
351 and add_top_level_vol ({ model = model; hash = hash } as t) name dev =
353 sprintf "<b>%s</b>\n<small>from %s</small>"
354 (markup_escape dev) (markup_escape name) in
356 let row = model#append () in
357 make_node t row (Top (Slave.Volume dev));
358 model#set ~row ~column:t.name_col markup
360 (* Generic function to make an openable node to the tree. *)
361 and make_node ({ model = model; hash = hash } as t) row content =
362 let hdata = NodeNotStarted, content in
363 store_hdata t row hdata;
365 (* Create a placeholder "loading ..." row underneath this node so
366 * the user has something to expand.
368 let placeholder = model#append ~parent:row () in
369 let hdata = IsLeaf, Loading in
370 store_hdata t placeholder hdata;
371 model#set ~row:placeholder ~column:t.name_col "<i>Loading ...</i>";
372 ignore (t.view#connect#row_expanded ~callback:(expand_row t))
374 and make_leaf ({ model = model; hash = hash } as t) row content =
375 let hdata = IsLeaf, content in
376 store_hdata t row hdata
378 (* This is called when the user expands a row. *)
379 and expand_row ({ model = model; hash = hash } as t) row _ =
380 match get_hdata t row with
381 | NodeNotStarted, Top src ->
382 (* User has opened a top level node that was not previously opened. *)
384 (* Mark this row as loading, so we don't try to open it again. *)
385 let hdata = NodeLoading, Top src in
386 store_hdata t row hdata;
388 (* Get a stable path for this row. *)
389 let path = model#get_path row in
391 Slave.read_directory ~fail:(when_read_directory_fail t path)
392 src "/" (when_read_directory t path)
394 | NodeNotStarted, Directory direntry ->
395 (* User has opened a filesystem directory not previously opened. *)
397 (* Mark this row as loading. *)
398 let hdata = NodeLoading, Directory direntry in
399 store_hdata t row hdata;
401 (* Get a stable path for this row. *)
402 let path = model#get_path row in
404 let src, pathname = get_pathname t row in
406 Slave.read_directory ~fail:(when_read_directory_fail t path)
407 src pathname (when_read_directory t path)
409 | NodeLoading, _ | IsNode, _ -> ()
411 (* These are not nodes so it should never be possible to open them. *)
412 | _, File _ | IsLeaf, _ -> assert false
414 (* Node should not exist in the tree. *)
415 | NodeNotStarted, (Loading | ErrorMessage _) -> assert false
417 (* This is the callback when the slave has read the directory for us. *)
418 and when_read_directory ({ model = model } as t) path entries =
419 debug "when_read_directory";
421 let row = model#get_iter path in
423 (* Add the entries. *)
426 let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
428 let row = model#append ~parent:row () in
429 if is_directory stat.G.mode then
430 make_node t row (Directory direntry)
432 make_leaf t row (File direntry);
433 model#set ~row ~column:t.name_col (markup_of_name name);
434 model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode);
435 model#set ~row ~column:t.size_col stat.G.size;
436 model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime);
437 model#set ~row ~column:t.link_col (markup_of_link link)
440 (* Remove the placeholder entry. NB. Must be done AFTER adding
441 * the other entries, or else Gtk will unexpand the row.
444 let placeholder = model#iter_children ~nth:0 (Some row) in
445 ignore (model#remove placeholder)
446 with Invalid_argument _ -> ()
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 *)
477 let set_status_fn t status =
478 t.status <- Some status