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.
29 model : GTree.tree_store;
30 hash : (int, hdata) Hashtbl.t; (* hash from index_col -> hdata *)
31 index_col : int GTree.column;
32 mode_col : string GTree.column;
33 name_col : string GTree.column;
34 size_col : int64 GTree.column;
35 date_col : string GTree.column;
36 link_col : string GTree.column;
39 and hdata = state_t * content_t
41 (* The type of the hidden column used to implement on-demand loading.
42 * All rows are classified as either nodes or leafs (eg. a "node" might
43 * be a directory, or a top-level operating system, or anything else
44 * which the user could open and look inside).
47 | IsLeaf (* there are no children *)
48 | NodeNotStarted (* user has not tried to open this *)
49 | NodeLoading (* user tried to open it, still loading *)
50 | IsNode (* we've loaded the children of this directory *)
52 (* The actual content of a row. *)
54 | Loading (* special "loading ..." node *)
55 | ErrorMessage of string (* error message node *)
56 | Top of Slave.source (* top level OS or volume node *)
57 | Directory of Slave.direntry (* a directory *)
58 | File of Slave.direntry (* a file inc. special files *)
60 let loading_msg = "<i>Loading ...</i>"
62 let create ~packing () =
63 let view = GTree.view ~packing () in
64 (*view#set_rules_hint true;*)
65 view#selection#set_mode `MULTIPLE;
67 (* Hash of index numbers -> hdata. We do this because it's more
68 * efficient for the GC compared to storing OCaml objects directly in
71 let hash = Hashtbl.create 1023 in
73 (* The columns stored in each row. The hidden [index_col] column is
74 * an index into the hash table that records everything else about
75 * this row (see hdata above). The other display columns, eg.
76 * [name_col] contain Pango markup and thus have to be escaped.
78 let cols = new GTree.column_list in
80 let index_col = cols#add Gobject.Data.int in
82 let mode_col = cols#add Gobject.Data.string in
83 let name_col = cols#add Gobject.Data.string in
84 let size_col = cols#add Gobject.Data.int64 in
85 let date_col = cols#add Gobject.Data.string in
86 let link_col = cols#add Gobject.Data.string in
88 (* Create the model. *)
89 let model = GTree.tree_store cols in
90 view#set_model (Some (model :> GTree.model));
92 let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
93 let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
94 ignore (view#append_column mode_view);
96 let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
97 let name_view = GTree.view_column ~title:"Filename" ~renderer () in
98 name_view#set_max_width 300 (*pixels?!?*);
99 ignore (view#append_column name_view);
101 let renderer = GTree.cell_renderer_text [], ["text", size_col] in
102 let size_view = GTree.view_column ~title:"Size" ~renderer () in
103 ignore (view#append_column size_view);
105 let renderer = GTree.cell_renderer_text [], ["markup", date_col] in
106 let date_view = GTree.view_column ~title:"Date" ~renderer () in
107 ignore (view#append_column date_view);
109 let renderer = GTree.cell_renderer_text [], ["markup", link_col] in
110 let link_view = GTree.view_column ~title:"Link" ~renderer () in
111 ignore (view#append_column link_view);
113 { view = view; model = model; hash = hash;
114 index_col = index_col;
115 mode_col = mode_col; name_col = name_col; size_col = size_col;
116 date_col = date_col; link_col = link_col }
118 let clear { model = model; hash = hash } =
122 (* XXX No binding for g_markup_escape in lablgtk2. *)
123 let markup_escape name =
125 | '&' -> "&" | '<' -> "<" | '>' -> ">"
126 | c -> String.make 1 c
128 String.replace_chars f name
130 (* Mark up a filename for the name_col column. *)
131 let rec markup_of_name name =
134 (* Mark up symbolic links. *)
135 and markup_of_link link =
136 let link = markup_escape link in
137 if link <> "" then utf8_rarrow ^ " " ^ link else ""
140 and markup_of_mode mode =
142 if is_socket mode then 's'
143 else if is_symlink mode then 'l'
144 else if is_regular_file mode then '-'
145 else if is_block mode then 'b'
146 else if is_directory mode then 'd'
147 else if is_char mode then 'c'
148 else if is_fifo mode then 'p' else '?' in
149 let ru = if test_bit 0o400L mode then 'r' else '-' in
150 let wu = if test_bit 0o200L mode then 'w' else '-' in
151 let xu = if test_bit 0o100L mode then 'x' else '-' in
152 let rg = if test_bit 0o40L mode then 'r' else '-' in
153 let wg = if test_bit 0o20L mode then 'w' else '-' in
154 let xg = if test_bit 0o10L mode then 'x' else '-' in
155 let ro = if test_bit 0o4L mode then 'r' else '-' in
156 let wo = if test_bit 0o2L mode then 'w' else '-' in
157 let xo = if test_bit 0o1L mode then 'x' else '-' in
158 let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
160 let suid = test_bit 0o4000L mode in
161 let sgid = test_bit 0o2000L mode in
162 let svtx = test_bit 0o1000L mode in
163 if suid then str.[3] <- 's';
164 if sgid then str.[6] <- 's';
165 if svtx then str.[9] <- 't';
167 "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
169 (* File type tests. *)
170 and file_type mask mode = Int64.logand mode 0o170000L = mask
172 and is_socket mode = file_type 0o140000L mode
173 and is_symlink mode = file_type 0o120000L mode
174 and is_regular_file mode = file_type 0o100000L mode
175 and is_block mode = file_type 0o060000L mode
176 and is_directory mode = file_type 0o040000L mode
177 and is_char mode = file_type 0o020000L mode
178 and is_fifo mode = file_type 0o010000L mode
180 and test_bit mask mode = Int64.logand mode mask = mask
183 and markup_of_date time =
184 let time = Int64.to_float time in
185 let tm = Unix.localtime time in
186 sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
187 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
188 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
190 (* Store hdata into a row. *)
191 let store_hdata {model = model; hash = hash; index_col = index_col} row hdata =
192 let index = unique () in
193 Hashtbl.add hash index hdata;
194 model#set ~row ~column:index_col index
196 (* Retrieve previously stored hdata from a row. *)
197 let get_hdata { model = model; hash = hash; index_col = index_col } row =
198 let index = model#get ~row ~column:index_col in
199 try Hashtbl.find hash index
200 with Not_found -> assert false
202 let rec add ({ model = model; hash = hash } as t) name data =
205 (* Populate the top level of the filetree. If there are operating
206 * systems from inspection, these have their own top level entries
207 * followed by only unreferenced filesystems. If we didn't get
208 * anything from inspection, then at the top level we just show
211 let other_filesystems =
212 DeviceSet.of_list (List.map fst data.Slave.insp_all_filesystems) in
213 let other_filesystems =
214 List.fold_left (fun set { Slave.insp_filesystems = fses } ->
215 DeviceSet.subtract set (DeviceSet.of_array fses))
216 other_filesystems data.Slave.insp_oses in
218 (* Add top level operating systems. *)
219 List.iter (add_top_level_os t name) data.Slave.insp_oses;
221 (* Add top level left-over filesystems. *)
222 DeviceSet.iter (add_top_level_vol t name) other_filesystems;
224 (* Expand the first top level node. *)
225 match model#get_iter_first with
228 t.view#expand_row (model#get_path row)
230 and add_top_level_os ({ model = model; hash = hash } as t) name os =
232 sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
233 (markup_escape name) (markup_escape os.Slave.insp_hostname)
234 (markup_escape os.Slave.insp_product_name) in
236 let row = model#append () in
237 make_node t row (Top (Slave.OS os));
238 model#set ~row ~column:t.name_col markup
240 and add_top_level_vol ({ model = model; hash = hash } as t) name dev =
242 sprintf "<b>%s</b>\n<small>from %s</small>"
243 (markup_escape dev) (markup_escape name) in
245 let row = model#append () in
246 make_node t row (Top (Slave.Volume dev));
247 model#set ~row ~column:t.name_col markup
249 (* Generic function to make an openable node to the tree. *)
250 and make_node ({ model = model; hash = hash } as t) row content =
251 let hdata = NodeNotStarted, content in
252 store_hdata t row hdata;
254 (* Create a placeholder "loading ..." row underneath this node so
255 * the user has something to expand.
257 let placeholder = model#append ~parent:row () in
258 let hdata = IsLeaf, Loading in
259 store_hdata t placeholder hdata;
260 model#set ~row:placeholder ~column:t.name_col loading_msg;
261 ignore (t.view#connect#row_expanded ~callback:(expand_row t))
263 and make_leaf ({ model = model; hash = hash } as t) row content =
264 let hdata = IsLeaf, content in
265 store_hdata t row hdata
267 (* This is called when the user expands a row. *)
268 and expand_row ({ model = model; hash = hash } as t) row _ =
269 match get_hdata t row with
270 | NodeNotStarted, Top src ->
271 (* User has opened a top level node that was not previously opened. *)
273 (* Mark this row as loading, so we don't try to open it again. *)
274 let hdata = NodeLoading, Top src in
275 store_hdata t row hdata;
277 (* Get a stable path for this row. *)
278 let path = model#get_path row in
280 Slave.read_directory ~fail:(when_read_directory_fail t path)
281 src "/" (when_read_directory t path)
283 | NodeNotStarted, Directory direntry ->
284 (* User has opened a filesystem directory not previously opened. *)
286 (* Mark this row as loading. *)
287 let hdata = NodeLoading, Directory direntry in
288 store_hdata t row hdata;
290 (* Get a stable path for this row. *)
291 let path = model#get_path row in
293 let src, pathname = get_pathname t row in
295 Slave.read_directory ~fail:(when_read_directory_fail t path)
296 src pathname (when_read_directory t path)
298 | NodeLoading, _ | IsNode, _ -> ()
300 (* These are not nodes so it should never be possible to open them. *)
301 | _, File _ | IsLeaf, _ -> assert false
303 (* Node should not exist in the tree. *)
304 | NodeNotStarted, (Loading | ErrorMessage _) -> assert false
306 (* Search up to the top of the tree so we know if this directory
307 * comes from an OS or a volume, and the full path to here.
309 * The path up the tree will always look something like:
313 * \_ Loading <--- you are here
315 and get_pathname ({ model = model } as t) row =
316 let hdata = get_hdata t row in
317 let parent = model#iter_parent row in
319 match hdata, parent with
320 | (IsLeaf, Loading), Some parent ->
321 get_pathname t parent
322 | (IsLeaf, Loading), None ->
324 | (_, Directory { Slave.dent_name = name }), Some parent
325 | (_, File { Slave.dent_name = name }), Some parent ->
326 let src, parent_name = get_pathname t parent in
328 if parent_name = "/" then "/" ^ name
329 else parent_name ^ "/" ^ name in
331 | (_, Top src), _ -> src, "/"
332 | (_, Directory _), None -> assert false
333 | (_, File _), None -> assert false
334 | (_, Loading), _ -> assert false
335 | (_, ErrorMessage _), _ -> assert false
337 (* This is the callback when the slave has read the directory for us. *)
338 and when_read_directory ({ model = model } as t) path entries =
339 debug "when_read_directory";
341 let row = model#get_iter path in
343 (* Add the entries. *)
346 let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
348 let row = model#append ~parent:row () in
349 if is_directory stat.G.mode then
350 make_node t row (Directory direntry)
352 make_leaf t row (File direntry);
353 model#set ~row ~column:t.name_col (markup_of_name name);
354 model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode);
355 model#set ~row ~column:t.size_col stat.G.size;
356 model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime);
357 model#set ~row ~column:t.link_col (markup_of_link link)
360 (* Remove the placeholder entry. NB. Must be done AFTER adding
361 * the other entries, or else Gtk will unexpand the row.
364 let placeholder = model#iter_children ~nth:0 (Some row) in
365 ignore (model#remove placeholder)
366 with Invalid_argument _ -> ()
369 (* The original directory entry has now been loaded, so
372 let state, content = get_hdata t row in
373 let hdata = IsNode, content in
374 store_hdata t row hdata
376 (* This is called instead of when_read_directory when the read directory
377 * (or mount etc) failed. Convert the "Loading" entry into the
380 and when_read_directory_fail ({ model = model } as t) path exn =
381 debug "when_read_directory_fail: %s" (Printexc.to_string exn);
385 let row = model#get_iter path in
386 let row = model#iter_children ~nth:0 (Some row) in
388 let hdata = IsLeaf, ErrorMessage msg in
389 store_hdata t row hdata;
391 model#set ~row ~column:t.name_col (markup_escape msg)
394 (* unexpected exception: re-raise it *)