(* Guestfs Browser.
* Copyright (C) 2011 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
open Slave_types
open Utils
open Printf
(* I'd like to open CalendarLib but unfortunately it contains a
* submodule also called Utils, which clashes with our module.
*)
module CL = CalendarLib
module G = Guestfs
let rec file_properties tree path =
let model = tree#model in
let row = model#get_iter path in
let src, pathname = tree#get_pathname row in
debug "file properties dialog %s" pathname;
let title = "File properties" in
let d = GWindow.dialog ~width:400 ~height:600 ~title () in
let nb = GPack.notebook ~packing:d#vbox#add () in
let dent = tree#get_direntry row in
let stat = dent.dent_stat in
let mode = stat.G.mode in
let filetype =
if is_socket mode then "Socket"
else if is_symlink mode then "Symbolic link"
else if is_regular_file mode then "File"
else if is_block mode then "Block device"
else if is_directory mode then "Directory"
else if is_char mode then "Character device"
else if is_fifo mode then "Pipe"
else "Unknown" in
(* Fill in the basic information. *)
let vbox = tab filetype nb in
let tbl = GPack.table ~columns:4 ~rows:1 ~packing:vbox#add () in
tbl#set_col_spacings 8;
tbl#set_row_spacings 8;
wide tbl 0 "Name: " dent.dent_name;
wide tbl 1 "" pathname;
wide tbl 2 "Size: " (sprintf "%Ld bytes" stat.G.size);
wide tbl 3 "" (human_size stat.G.size);
simple tbl 4 0 "Type: " filetype;
if is_block mode || is_char mode then
simple tbl 4 2 "Device: " (sprintf "0x%Lx" stat.G.rdev)
else if is_symlink mode then
simple tbl 4 2 "Link: " dent.dent_link;
simple tbl 5 0 "UID: " (Int64.to_string stat.G.uid);
simple tbl 5 2 "GID: " (Int64.to_string stat.G.gid);
wide tbl 6 "" (file_permissions_string mode);
simple tbl 7 0 "Perms: " (sprintf "0%Lo" (mode &^ 0o777L));
simple tbl 7 2 "Sticky bit: " (if is_svtx mode then "yes" else "no");
simple tbl 8 0 "Setuid bit: " (if is_suid mode then "yes" else "no");
simple tbl 8 2 "Setgid bit: " (if is_sgid mode then "yes" else "no");
wide2 tbl 9 "Last access: " (display_time stat.G.atime);
wide2 tbl 10 "Last modification: " (display_time stat.G.mtime);
wide2 tbl 11 "Last status change: " (display_time stat.G.ctime);
(* Extended attrs. *)
let vbox = tab "Extended attrs" nb in
xattrs_view ~packing:vbox#add src pathname;
(* Make sure dialog is destroyed when the tree is cleared. *)
let sigid =
tree#clear_tree ~callback:(
fun () ->
debug "inspection clear_tree -> destroy dialog";
d#destroy ()
) in
let destroy_dialog () =
tree#disconnect sigid;
d#destroy ()
in
(* Add a close button. *)
let close_button = GButton.button ~label:"Close"
~packing:d#action_area#add () in
ignore (close_button#connect#clicked ~callback:destroy_dialog);
(* Destroy dialog when WM close button is pressed. *)
ignore (d#connect#destroy ~callback:destroy_dialog);
d#show ()
(* Helper functions. *)
and tab text nb =
let vbox = GPack.vbox ~border_width:8 () in
let tab_label = (GMisc.label ~text () :> GObj.widget) in
ignore (nb#append_page ~tab_label (vbox :> GObj.widget));
vbox
and simple tbl top left label text =
let markup = sprintf "%s" (markup_escape text) in
ignore (GMisc.label ~xalign:1. ~text:label
~packing:(tbl#attach ~top ~left) ());
let left = left + 1 in
ignore (GMisc.label ~xalign:0. ~markup ~packing:(tbl#attach ~top ~left) ());
and wide tbl top label text =
let markup = sprintf "%s" (markup_escape text) in
ignore (GMisc.label ~xalign:1.
~text:label ~packing:(tbl#attach ~top ~left:0) ());
ignore (GMisc.label ~xalign:0.
~markup ~packing:(tbl#attach ~top ~left:1 ~right:4) ());
and wide2 tbl top label text =
let markup = sprintf "%s" (markup_escape text) in
ignore (GMisc.label ~xalign:1.
~text:label ~packing:(tbl#attach ~top ~left:0 ~right:2) ());
ignore (GMisc.label ~xalign:0.
~markup ~packing:(tbl#attach ~top ~left:2 ~right:4) ());
and display_time t =
let t = Int64.to_float t in
let cal = CL.Calendar.from_unixfloat t in
let cal = CL.Calendar.convert cal CL.Time_Zone.UTC CL.Time_Zone.Local in
CL.Printer.Calendar.to_string cal
(* Extended attrs: loaded on demand. *)
and xattrs_view ?packing src pathname =
let cols = new GTree.column_list in
let name_col = cols#add Gobject.Data.string in
let value_col = cols#add Gobject.Data.string in
let model = GTree.list_store cols in
let sw =
GBin.scrolled_window ?packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in
let view = GTree.view ~model ~packing:sw#add () in
view#selection#set_mode `NONE;
let renderer = GTree.cell_renderer_text [], ["text", name_col] in
let vc = GTree.view_column ~title:"Name" ~renderer () in
vc#set_resizable true;
ignore (view#append_column vc);
let renderer = GTree.cell_renderer_text [], ["text", value_col] in
let vc = GTree.view_column ~title:"Value" ~renderer () in
vc#set_resizable true;
ignore (view#append_column vc);
Slave.file_xattrs src pathname
(when_xattrs_loaded model name_col value_col)
and when_xattrs_loaded model name_col value_col xattrs =
Array.iter (
fun { G.attrname = name; attrval = value } ->
let value = sprintf "%S" value in (* OCaml string escaping *)
let row = model#append () in
model#set ~row ~column:name_col name;
model#set ~row ~column:value_col value
) xattrs