op_file_properties.ml

   1 (* Guestfs Browser.
   2  * Copyright (C) 2011 Red Hat Inc.
   3  *
   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.
   8  *
   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.
  13  *
  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.
  17  *)
  18
  19 open Slave_types
  20 open Utils
  21
  22 open Printf
  23
  24 (* I'd like to open CalendarLib but unfortunately it contains a
  25  * submodule also called Utils, which clashes with our module.
  26  *)
  27 module CL = CalendarLib
  28 module G = Guestfs
  29
  30 let rec file_properties tree path =
  31   let model = tree#model in
  32   let row = model#get_iter path in
  33   let src, pathname = tree#get_pathname row in
  34
  35   debug "file properties dialog %s" pathname;
  36
  37   let title = "File properties" in
  38   let d = GWindow.dialog ~width:400 ~height:600 ~title () in
  39   let nb = GPack.notebook ~packing:d#vbox#add () in
  40
  41   let dent = tree#get_direntry row in
  42   let stat = dent.dent_stat in
  43   let mode = stat.G.mode in
  44
  45   let filetype =
  46     if is_socket mode then "Socket"
  47     else if is_symlink mode then "Symbolic link"
  48     else if is_regular_file mode then "File"
  49     else if is_block mode then "Block device"
  50     else if is_directory mode then "Directory"
  51     else if is_char mode then "Character device"
  52     else if is_fifo mode then "Pipe"
  53     else "Unknown" in
  54
  55   (* Fill in the basic information. *)
  56   let vbox = tab filetype nb in
  57   let tbl = GPack.table ~columns:4 ~rows:1 ~packing:vbox#add () in
  58   tbl#set_col_spacings 8;
  59   tbl#set_row_spacings 8;
  60
  61   wide tbl 0 "Name: " dent.dent_name;
  62   wide tbl 1 "" pathname;
  63   wide tbl 2 "Size: " (sprintf "%Ld bytes" stat.G.size);
  64   wide tbl 3 "" (human_size stat.G.size);
  65   simple tbl 4 0 "Type: " filetype;
  66   if is_block mode || is_char mode then
  67     simple tbl 4 2 "Device: " (sprintf "0x%Lx" stat.G.rdev)
  68   else if is_symlink mode then
  69     simple tbl 4 2 "Link: " dent.dent_link;
  70   simple tbl 5 0 "UID: " (Int64.to_string stat.G.uid);
  71   simple tbl 5 2 "GID: " (Int64.to_string stat.G.gid);
  72
  73   wide tbl 6 "" (file_permissions_string mode);
  74
  75   simple tbl 7 0 "Perms: " (sprintf "0%Lo" (mode &^ 0o777L));
  76   simple tbl 7 2 "Sticky bit: " (if is_svtx mode then "yes" else "no");
  77   simple tbl 8 0 "Setuid bit: " (if is_suid mode then "yes" else "no");
  78   simple tbl 8 2 "Setgid bit: " (if is_sgid mode then "yes" else "no");
  79
  80   wide2 tbl 9 "Last access: " (display_time stat.G.atime);
  81   wide2 tbl 10 "Last modification: " (display_time stat.G.mtime);
  82   wide2 tbl 11 "Last status change: " (display_time stat.G.ctime);
  83
  84   (* Extended attrs. *)
  85   let vbox = tab "Extended attrs" nb in
  86   xattrs_view ~packing:vbox#add src pathname;
  87
  88   (* Make sure dialog is destroyed when the tree is cleared. *)
  89   let sigid =
  90     tree#clear_tree ~callback:(
  91       fun () ->
  92         debug "inspection clear_tree -> destroy dialog";
  93         d#destroy ()
  94     ) in
  95
  96   let destroy_dialog () =
  97     tree#disconnect sigid;
  98     d#destroy ()
  99   in
 100
 101   (* Add a close button. *)
 102   let close_button = GButton.button ~label:"Close"
 103     ~packing:d#action_area#add () in
 104   ignore (close_button#connect#clicked ~callback:destroy_dialog);
 105
 106   (* Destroy dialog when WM close button is pressed. *)
 107   ignore (d#connect#destroy ~callback:destroy_dialog);
 108
 109   d#show ()
 110
 111 (* Helper functions. *)
 112 and tab text nb =
 113   let vbox = GPack.vbox ~border_width:8 () in
 114   let tab_label = (GMisc.label ~text () :> GObj.widget) in
 115   ignore (nb#append_page ~tab_label (vbox :> GObj.widget));
 116   vbox
 117
 118 and simple tbl top left label text =
 119   let markup = sprintf "<b>%s</b>" (markup_escape text) in
 120   ignore (GMisc.label ~xalign:1. ~text:label
 121             ~packing:(tbl#attach ~top ~left) ());
 122   let left = left + 1 in
 123   ignore (GMisc.label ~xalign:0. ~markup ~packing:(tbl#attach ~top ~left) ());
 124
 125 and wide tbl top label text =
 126   let markup = sprintf "<b>%s</b>" (markup_escape text) in
 127   ignore (GMisc.label ~xalign:1.
 128             ~text:label ~packing:(tbl#attach ~top ~left:0) ());
 129   ignore (GMisc.label ~xalign:0.
 130             ~markup ~packing:(tbl#attach ~top ~left:1 ~right:4) ());
 131
 132 and wide2 tbl top label text =
 133   let markup = sprintf "<b>%s</b>" (markup_escape text) in
 134   ignore (GMisc.label ~xalign:1.
 135             ~text:label ~packing:(tbl#attach ~top ~left:0 ~right:2) ());
 136   ignore (GMisc.label ~xalign:0.
 137             ~markup ~packing:(tbl#attach ~top ~left:2 ~right:4) ());
 138
 139 and display_time t =
 140   let t = Int64.to_float t in
 141   let cal = CL.Calendar.from_unixfloat t in
 142   let cal = CL.Calendar.convert cal CL.Time_Zone.UTC CL.Time_Zone.Local in
 143   CL.Printer.Calendar.to_string cal
 144
 145 (* Extended attrs: loaded on demand. *)
 146 and xattrs_view ?packing src pathname =
 147   let cols = new GTree.column_list in
 148   let name_col = cols#add Gobject.Data.string in
 149   let value_col = cols#add Gobject.Data.string in
 150
 151   let model = GTree.list_store cols in
 152
 153   let sw =
 154     GBin.scrolled_window ?packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in
 155
 156   let view = GTree.view ~model ~packing:sw#add () in
 157   view#selection#set_mode `NONE;
 158
 159   let renderer = GTree.cell_renderer_text [], ["text", name_col] in
 160   let vc = GTree.view_column ~title:"Name" ~renderer () in
 161   vc#set_resizable true;
 162   ignore (view#append_column vc);
 163   let renderer = GTree.cell_renderer_text [], ["text", value_col] in
 164   let vc = GTree.view_column ~title:"Value" ~renderer () in
 165   vc#set_resizable true;
 166   ignore (view#append_column vc);
 167
 168   Slave.file_xattrs src pathname
 169     (when_xattrs_loaded model name_col value_col)
 170
 171 and when_xattrs_loaded model name_col value_col xattrs =
 172   Array.iter (
 173     fun { G.attrname = name; attrval = value } ->
 174       let value = sprintf "%S" value in (* OCaml string escaping *)
 175       let row = model#append () in
 176       model#set ~row ~column:name_col name;
 177       model#set ~row ~column:value_col value
 178   ) xattrs