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 *)
51 | Loading (* special row contains the "Loading ..." message *)
53 (* The actual content of a row. *)
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 400 (*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 and add_top_level_os ({ model = model; hash = hash } as t) name os =
226 sprintf "<b>%s</b>: %s (%s)"
227 (markup_of_name name) (markup_of_name os.Slave.insp_hostname)
228 (markup_of_name os.Slave.insp_product_name) in
230 let row = model#append () in
231 make_node t row (Top (Slave.OS os));
232 model#set ~row ~column:t.name_col markup
234 and add_top_level_vol ({ model = model; hash = hash } as t) name dev =
236 sprintf "<b>%s</b>: %s" (markup_of_name name) (markup_of_name dev) in
238 let row = model#append () in
239 make_node t row (Top (Slave.Volume dev));
240 model#set ~row ~column:t.name_col markup
242 (* Generic function to make an openable node to the tree. *)
243 and make_node ({ model = model; hash = hash } as t) row content =
244 let hdata = NodeNotStarted, content in
245 store_hdata t row hdata;
247 (* Create a placeholder "loading ..." row underneath this node so
248 * the user has something to expand.
250 let placeholder = model#append ~parent:row () in
251 let hdata = Loading, NoContent in
252 store_hdata t placeholder hdata;
253 model#set ~row:placeholder ~column:t.name_col loading_msg;
254 ignore (t.view#connect#row_expanded ~callback:(expand_row t))
256 and make_leaf ({ model = model; hash = hash } as t) row content =
257 let hdata = IsLeaf, content in
258 store_hdata t row hdata
260 (* This is called when the user expands a row. *)
261 and expand_row ({ model = model; hash = hash } as t) row _ =
262 match get_hdata t row with
263 | NodeNotStarted, Top src ->
264 (* User has opened a top level node that was not previously opened. *)
266 (* Mark this row as loading, so we don't try to open it again. *)
267 let hdata = NodeLoading, Top src in
268 store_hdata t row hdata;
270 (* Get a stable path for this row. *)
271 let path = model#get_path row in
273 Slave.read_directory src "/" (when_read_directory t path)
275 | NodeNotStarted, Directory direntry ->
276 (* User has opened a filesystem directory not previously opened. *)
278 (* Mark this row as loading. *)
279 let hdata = NodeLoading, Directory direntry in
280 store_hdata t row hdata;
282 (* Get a stable path for this row. *)
283 let path = model#get_path row in
285 let src, pathname = get_pathname t row in
287 Slave.read_directory src pathname (when_read_directory t path)
289 | NodeLoading, _ | IsNode, _ -> ()
291 (* These are not nodes so it should never be possible to open them. *)
292 | _, File _ | IsLeaf, _ | Loading, _ -> assert false
294 (* Should not exist in the tree. *)
295 | NodeNotStarted, NoContent -> assert false
297 (* Search up to the top of the tree so we know if this directory
298 * comes from an OS or a volume, and the full path to here.
300 * The path up the tree will always look something like:
304 * \_ Loading <--- you are here
306 and get_pathname ({ model = model } as t) row =
307 let hdata = get_hdata t row in
308 let parent = model#iter_parent row in
310 match hdata, parent with
311 | (Loading, NoContent), Some parent ->
312 get_pathname t parent
313 | (Loading, NoContent), None ->
315 | (_, Directory { Slave.dent_name = name }), Some parent
316 | (_, File { Slave.dent_name = name }), Some parent ->
317 let src, parent_name = get_pathname t parent in
319 if parent_name = "/" then "/" ^ name
320 else parent_name ^ "/" ^ name in
322 | (_, Top src), _ -> src, "/"
323 | (_, Directory _), None | (_, File _), None -> assert false
324 | (_, NoContent), _ -> assert false
326 (* This is the callback when the slave has read the directory for us. *)
327 and when_read_directory ({ model = model } as t) path entries =
328 debug "when_read_directory";
330 let row = model#get_iter path in
332 (* Add the entries. *)
335 let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
337 let row = model#append ~parent:row () in
338 if is_directory stat.G.mode then
339 make_node t row (Directory direntry)
341 make_leaf t row (File direntry);
342 model#set ~row ~column:t.name_col (markup_of_name name);
343 model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode);
344 model#set ~row ~column:t.size_col stat.G.size;
345 model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime);
346 model#set ~row ~column:t.link_col (markup_of_link link)
349 (* Remove the placeholder entry. NB. Must be done AFTER adding
350 * the other entries, or else Gtk will unexpand the row.
353 let placeholder = model#iter_children ~nth:0 (Some row) in
354 ignore (model#remove placeholder)
355 with Invalid_argument _ -> ()
358 (* The original directory entry has now been loaded, so
361 let state, content = get_hdata t row in
362 let hdata = IsNode, content in
363 store_hdata t row hdata