- (* Mark this row as now loading, so we don't start another
- * directory read if the user expands it again.
- *)
- model#set ~row ~column:state_col dirLoading
-
- | 0 (* isFile *) | 2 (* dirLoading *) | 3 (* isDir *) -> ()
- | 4 (* loading *) -> assert false
- | _ -> assert false
-
-and read_directory_cb tree path entries =
- let model, _, hash, _, _,
- (state_col, index_col, mode_col, name_col, size_col, date_col,
- link_col)
- = tree in
-
- let row = model#get_iter path in
-
- (* Add the entries. *)
- List.iter (
- fun direntry ->
- let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
- direntry in
- let row = model#append ~parent:row () in
- if is_directory stat.G.mode then
- add_directory_row tree row name (Some direntry)
- else (
- let index = unique () in
- Hashtbl.add hash index direntry;
- model#set ~row ~column:state_col isFile;
- model#set ~row ~column:index_col index;
- model#set ~row ~column:name_col (markup_of_name name);
- model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
- model#set ~row ~column:size_col stat.G.size;
- model#set ~row ~column:date_col (markup_of_date stat.G.mtime);
- model#set ~row ~column:link_col (markup_of_link link)
- )
- ) entries;
-
- (* Remove the placeholder entry. NB. Must be done AFTER adding
- * the other entries, or else Gtk will unexpand the row.
- *)
- (try
- let placeholder = model#iter_children ~nth:0 (Some row) in
- ignore (model#remove placeholder)
- with Invalid_argument _ -> ());
-
- (* The original directory entry has now been loaded, so
- * update its state.
- *)
- model#set ~row ~column:state_col isDir
-
-(* Get the actual full pathname of a row. *)
-and get_pathname tree row =
- let model, _, _, _, _, _ = tree in
-
- match model#iter_parent row with
- | None -> "/"
- | Some parent ->
- match get_direntry_of_row tree row with
- | Some { Slave.dent_name = name } ->
- let pname = get_pathname tree parent in
- if pname = "/" then "/" ^ name else pname ^ "/" ^ name
- | None ->
- assert false
-
-(* Get the directory entry from a row (contains the stat(2) results etc).
- * Some rows don't have the required information (eg. placeholder rows
- * and currently the root directory) and for them we return [None].
- *)
-and get_direntry_of_row tree row =
- let model, _, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
- let index = model#get ~row ~column:index_col in
- try Some (Hashtbl.find hash index)
- with Not_found -> None
-
-(* XXX No binding for g_markup_escape in lablgtk2. *)
-and markup_escape name =
- let f = function
- | '&' -> "&" | '<' -> "<" | '>' -> ">"
- | c -> String.make 1 c
- in
- String.replace_chars f name
-
-(* Mark up a filename for the name_col column. *)
-and markup_of_name name =
- (* First, protect against any markup in the name. *)
- let name = markup_escape name in
- name
-
-(* Mark up symbolic links. *)
-and markup_of_link link =
- let link = markup_escape link in
- if link <> "" then utf8_rarrow ^ " " ^ link else ""
-
-(* Mark up mode. *)
-and markup_of_mode mode =
- let c =
- if is_socket mode then 's'
- else if is_symlink mode then 'l'
- else if is_regular_file mode then '-'
- else if is_block mode then 'b'
- else if is_directory mode then 'd'
- else if is_char mode then 'c'
- else if is_fifo mode then 'p' else '?' in
- let ru = if test_bit 0o400L mode then 'r' else '-' in
- let wu = if test_bit 0o200L mode then 'w' else '-' in
- let xu = if test_bit 0o100L mode then 'x' else '-' in
- let rg = if test_bit 0o40L mode then 'r' else '-' in
- let wg = if test_bit 0o20L mode then 'w' else '-' in
- let xg = if test_bit 0o10L mode then 'x' else '-' in
- let ro = if test_bit 0o4L mode then 'r' else '-' in
- let wo = if test_bit 0o2L mode then 'w' else '-' in
- let xo = if test_bit 0o1L mode then 'x' else '-' in
- let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
-
- let suid = test_bit 0o4000L mode in
- let sgid = test_bit 0o2000L mode in
- let svtx = test_bit 0o1000L mode in
- if suid then str.[3] <- 's';
- if sgid then str.[6] <- 's';
- if svtx then str.[9] <- 't';
-
- "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
-
-(* File type tests. *)
-and file_type mask mode = Int64.logand mode 0o170000L = mask
-
-and is_socket mode = file_type 0o140000L mode
-and is_symlink mode = file_type 0o120000L mode
-and is_regular_file mode = file_type 0o100000L mode
-and is_block mode = file_type 0o060000L mode
-and is_directory mode = file_type 0o040000L mode
-and is_char mode = file_type 0o020000L mode
-and is_fifo mode = file_type 0o010000L mode
-
-and test_bit mask mode = Int64.logand mode mask = mask
-
-(* Mark up dates. *)
-and markup_of_date time =
- let time = Int64.to_float time in
- let tm = Unix.localtime time in
- sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
- (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
- tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec