filetree_type.ml

   1 (* Guestfs Browser.
   2  * Copyright (C) 2010 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 Utils
  20 open Printf
  21
  22 (* See struct/field description in .mli file. *)
  23 type t = {
  24   view : GTree.view;
  25   model : GTree.tree_store;
  26   hash : (int, hdata) Hashtbl.t;
  27   index_col : int GTree.column;
  28   mode_col : string GTree.column;
  29   name_col : string GTree.column;
  30   size_col : string GTree.column;
  31   date_col : string GTree.column;
  32 }
  33
  34 and hdata = {
  35   mutable state : state_t;
  36   content : content_t;
  37   mutable visited : bool;
  38 }
  39
  40 and state_t =
  41   | IsLeaf
  42   | NodeNotStarted
  43   | NodeLoading
  44   | IsNode
  45
  46 and content_t =
  47   | Loading
  48   | ErrorMessage of string
  49   | Info of string
  50   | Top of Slave.source
  51   | Directory of Slave.direntry
  52   | File of Slave.direntry
  53
  54 (* Store hdata into a row. *)
  55 let store_hdata {model = model; hash = hash; index_col = index_col} row hdata =
  56   let index = unique () in
  57   Hashtbl.add hash index hdata;
  58   model#set ~row ~column:index_col index
  59
  60 (* Retrieve previously stored hdata from a row. *)
  61 let get_hdata { model = model; hash = hash; index_col = index_col } row =
  62   let index = model#get ~row ~column:index_col in
  63   try Hashtbl.find hash index
  64   with Not_found -> assert false
  65
  66 (* Iterate over children of node, looking for matching hdata. *)
  67 let find_child_node_by_content ({ model = model } as t) row c =
  68   let rec loop row =
  69     if (get_hdata t row).content = c then
  70       row
  71     else if model#iter_next row then
  72       loop row
  73     else
  74       raise Not_found
  75   in
  76
  77   if not (model#iter_has_child row) then
  78     raise Not_found;
  79
  80   let first_child = model#iter_children (Some row) in
  81   loop first_child
  82
  83 (* Search up to the top of the tree so we know if this directory
  84  * comes from an OS or a volume, and the full path to here.
  85  *
  86  * The path up the tree will always look something like:
  87  *     Top
  88  *       \_ Directory
  89  *            \_ Directory
  90  *                 \_ Loading    <--- you are here
  91  *)
  92 let rec get_pathname ({ model = model } as t) row =
  93   let hdata = get_hdata t row in
  94   let parent = model#iter_parent row in
  95
  96   match hdata, parent with
  97   | { state=IsLeaf; content=(Loading|ErrorMessage _|Info _) }, Some parent ->
  98       get_pathname t parent
  99   | { state=IsLeaf; content=(Loading|ErrorMessage _|Info _) }, None ->
 100       assert false
 101   | { content=Directory { Slave.dent_name = name }}, Some parent
 102   | { content=File { Slave.dent_name = name }}, Some parent ->
 103       let src, parent_name = get_pathname t parent in
 104       let path =
 105         if parent_name = "/" then "/" ^ name
 106         else parent_name ^ "/" ^ name in
 107       src, path
 108   | { content=Top src }, _ -> src, "/"
 109   | { content=Directory _}, None -> assert false
 110   | { content=File _}, None -> assert false
 111   | { content=Loading }, _ -> assert false
 112   | { content=ErrorMessage _}, _ -> assert false
 113   | { content=Info _}, _ -> assert false
 114
 115 (* Base colours. XXX Should be configurable somewhere. *)
 116 let file_color = 0x20, 0x20, 0xff  (* regular file *)
 117 let dir_color = 0x80, 0x80, 0x20   (* directory *)
 118 let symlink_color = file_color     (* symlink *)
 119 let suid_color = 0x20, 0x20, 0x80  (* setuid bit set on regular file *)
 120 let suid_bgcolor = 0xff, 0xc0, 0xc0
 121 let sgid_color = suid_color        (* setgid bit set on regular file *)
 122 let sgid_bgcolor = suid_bgcolor
 123 let block_color = 0x00, 0x60, 0x60 (* block device *)
 124 let char_color = block_color       (* char device *)
 125 let fifo_color = 0x60, 0x00, 0x60  (* fifo *)
 126 let socket_color = fifo_color      (* socket *)
 127 let other_color = file_color       (* anything not one of the above *)
 128
 129 (* Mark up a filename for the name_col column.
 130  *
 131  * XXX This shouldn't be in Filetree_type module, but we have to have
 132  * it here because set_visited is here.
 133  *
 134  * See also
 135  * http://library.gnome.org/devel/pango/stable/PangoMarkupFormat.html
 136  *)
 137 let rec markup_of_name ?(visited = false) direntry =
 138   let name = direntry.Slave.dent_name in
 139   let mode = direntry.Slave.dent_stat.Guestfs.mode in
 140   if is_directory mode then (           (* directory *)
 141     let fg = if not visited then normal dir_color else darken dir_color in
 142     sprintf "<span weight=\"bold\" fgcolor=\"%s\">%s</span>"
 143       fg (markup_escape name)
 144   )
 145   else if is_symlink mode then (        (* symlink *)
 146     let link = direntry.Slave.dent_link in
 147     let fg =
 148       if not visited then normal symlink_color else darken symlink_color in
 149     sprintf "<span style=\"italic\" fgcolor=\"%s\">%s</span> %s <span style=\"italic\" fgcolor=\"%s\">%s</span>"
 150       fg (markup_escape name) utf8_rarrow fg (markup_escape link)
 151   )
 152   else (                                (* not directory, not symlink *)
 153     let fg, bg =
 154       if is_regular_file mode then (
 155         if is_suid mode then suid_color, Some suid_bgcolor
 156         else if is_sgid mode then sgid_color, Some sgid_bgcolor
 157         else file_color, None
 158       )
 159       else if is_block mode then block_color, None
 160       else if is_char mode then char_color, None
 161       else if is_fifo mode then fifo_color, None
 162       else if is_socket mode then socket_color, None
 163       else other_color, None in
 164     let fg = if not visited then normal fg else darken fg in
 165     let bg =
 166       match bg with
 167       | Some bg -> sprintf " bgcolor=\"%s\"" (normal bg)
 168       | None -> "" in
 169     sprintf "<span fgcolor=\"%s\"%s>%s</span>"
 170       fg bg (markup_escape name)
 171   )
 172
 173 and normal (r, g, b) =
 174   let r = if r < 0 then 0 else if r > 255 then 255 else r in
 175   let g = if g < 0 then 0 else if g > 255 then 255 else g in
 176   let b = if b < 0 then 0 else if b > 255 then 255 else b in
 177   sprintf "#%02x%02x%02x" r g b
 178
 179 and darken (r, g, b) =
 180   normal (r * 4 / 10, g * 4 / 10, b * 4 / 10)
 181
 182 (* This is a bit of a hack.  Ideally just setting 'visited' would
 183  * darken the colour when the cell was re-rendered.  However that would
 184  * mean we couldn't store other stuff in the name column.  Therefore,
 185  * repopulate the name column.
 186  *)
 187 let set_visited ({ model = model; name_col = name_col } as t) row =
 188   let hdata = get_hdata t row in
 189   if hdata.visited = false then (
 190     hdata.visited <- true;
 191     match hdata.content with
 192     | Directory direntry | File direntry ->
 193         debug "set_visited %s" direntry.Slave.dent_name;
 194         model#set ~row ~column:name_col
 195           (markup_of_name ~visited:true direntry)
 196     | Loading | ErrorMessage _ | Info _ | Top _ -> ()
 197   )