gdb/gdbtk/library/vartree.itb

   1 # Variable tree implementation for Insight.
   2 # Copyright (C) 2002 Red Hat, Inc.
   3 #
   4 # This program is free software; you can redistribute it and/or modify it
   5 # under the terms of the GNU General Public License (GPL) as published by
   6 # the Free Software Foundation; either version 2 of the License, or (at
   7 # 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 itcl::body  VarTree::constructor {args} {
  15   debug $args
  16   if {!$initialized} {
  17     _init_data
  18   }
  19   eval itk_initialize $args
  20
  21   itk_component add canvas {
  22     iwidgets::scrolledcanvas $itk_interior.c -autoresize 1 -hscrollmode dynamic -vscrollmode dynamic \
  23       -background $::Colors(textbg) -borderwidth 0 -highlightthickness 0
  24   }
  25   set c [$itk_component(canvas) childsite]
  26   pack $itk_component(canvas) -side top -fill both -expand 1
  27   bind $c <1> "[code $this clicked %W %x %y 0]"
  28
  29   # Add popup menu - we populate it in _but3
  30   itk_component add popup {
  31     menu $itk_interior.pop -tearoff 0
  32   } {}
  33   set pop $itk_component(popup)
  34   $pop configure -disabledforeground $::Colors(fg)
  35   bind $c <3> [code $this _but3 %x %y %X %Y]
  36
  37   set selection {}
  38   set selidx {}
  39   after idle [code $this build]
  40 }
  41
  42 itcl::body  VarTree::destructor {} {
  43   debug
  44 }
  45
  46 itcl::body  VarTree::build {} {
  47   debug
  48   $c delete all
  49   catch {unset var_to_items}
  50   catch {unset item_to_var}
  51   set _y 30
  52   buildlayer $rootlist 10
  53   $c config -scrollregion [$c bbox all] -background $::Colors(textbg) -borderwidth 0 -highlightthickness 0
  54   update 1
  55   drawselection
  56 }
  57
  58 itcl::body  VarTree::buildlayer {tlist in} {
  59   set start [expr $_y - 10]
  60
  61   foreach var $tlist {
  62     set y $_y
  63     incr _y 17
  64
  65     if {$in > 10} {
  66       $c create line $in $y [expr $in+10] $y -fill $colors(line)
  67     }
  68     set x [expr $in + 12]
  69
  70     set j1 [$c create text $x $y -text "[$var name] = " -fill $colors(name) -anchor w -font global/fixed]
  71     set x [expr [lindex [$c bbox $j1] 2] + 5]
  72     set j2 [$c create text $x $y -text "([$var type])" -fill $colors(type) -anchor w -font global/fixed]
  73     set x [expr [lindex [$c bbox $j2] 2] + 5]
  74     if {[catch {$var value} val]} {
  75       # error accessing memory, etc.
  76       set j3 [$c create text $x $y -text $val -fill $colors(error) -anchor w -font global/fixed]
  77     } else {
  78       set j3 [$c create text $x $y -text $val -fill $colors(value) -anchor w -font global/fixed]
  79     }
  80
  81     set var_to_items($var) [list $j1 $j2 $j3]
  82     set item_to_var($j1) $var
  83     set item_to_var($j2) $var
  84     set item_to_var($j3) $var
  85
  86     $c bind $j1 <Double-1> "[code $this clicked %W %x %y 1]"
  87     $c bind $j2 <Double-1> "[code $this clicked %W %x %y 1]"
  88     $c bind $j3 <Double-1> "[code $this edit $j3];break"
  89
  90     if {[$var numChildren]} {
  91       if {[closed $var]} {
  92         set j [$c create image $in $y -image closedbm]
  93         $c bind $j <1> "[code $this open $var]"
  94       } else {
  95         set j [$c create image $in $y -image openbm]
  96         $c bind $j <1> "[code $this close $var]"
  97         buildlayer [$var children] [expr $in+18]
  98       }
  99     }
 100   }
 101   if {$in > 10} {
 102     $c lower [$c create line $in $start $in [expr $y+1] -fill $colors(line) ]
 103   }
 104 }
 105
 106 # add: add a list of varobj to the tree
 107 itcl::body  VarTree::add {var} {
 108   debug $var
 109   if {$var == ""} {return}
 110   set rootlist [concat $rootlist $var]
 111   after idle [code $this build]
 112 }
 113
 114 # remove: remove a varobj from the tree
 115 # if the name is "all" then remove all
 116 itcl::body  VarTree::remove {name} {
 117   debug $name
 118   if {$name == ""} {return}
 119   if {$name == "all"} {
 120     set rootlist {}
 121   } else {
 122     set rootlist [lremove $rootlist $name]
 123   }
 124   after idle [code $this build]
 125 }
 126
 127 # update a var
 128 itcl::body  VarTree::update_var {var enabled check} {
 129   if {$enabled && $check} {return}
 130   lassign $var_to_items($var) nam typ val
 131   if {$enabled} {
 132     $c itemconfigure $nam -fill $colors(name)
 133     $c itemconfigure $typ -fill $colors(type)
 134
 135     if {[catch {$var value} value]} {
 136       set color $colors(error)
 137     } elseif {[$c itemcget $val -text] != $value} {
 138       set color $colors(change)
 139     } else {
 140       set color $colors(value)
 141     }
 142     $c itemconfigure $val -text $value -fill $color
 143   } else {
 144     $c itemconfigure $nam -fill $colors(disabled)
 145     $c itemconfigure $typ -fill $colors(disabled)
 146     $c itemconfigure $val -fill $colors(disabled)
 147   }
 148
 149   if {![closed $var] && [$var numChildren]} {
 150     foreach child [$var children] {
 151       update_var $child $enabled $check
 152     }
 153   }
 154 }
 155
 156 # update: update the values of the vars in the tree.
 157 # The "check" argument is a hack we have to do because
 158 # [$varobj value] does not return an error; only [$varobj update]
 159 # does.  So after changing the tree layout in build, we must then
 160 # do an update.  The "check" argument just optimizes things a bit over
 161 # a normal update by not fetching values, just calling update.
 162 itcl::body  VarTree::update {{check 0}} {
 163   debug
 164
 165   # delete selection box if it is visible
 166   if {$selidx != ""} {
 167     $c delete $selidx
 168   }
 169
 170   # update all the root variables
 171   foreach var $rootlist {
 172     if {[$var update] == "-1"} {
 173       set enabled 0
 174     } else {
 175       set enabled 1
 176     }
 177     update_var $var $enabled $check
 178   }
 179 }
 180
 181 # Draw the selection highlight
 182 itcl::body  VarTree::drawselection {} {
 183   #debug "selidx=$selidx selection=$selection"
 184   if {$selidx != ""} {
 185     $c delete $selidx
 186   }
 187   if {$selection == ""} return
 188   if {![info exists var_to_items($selection)]} return
 189   set bbox [eval "$c bbox $var_to_items($selection)"]
 190   if {[llength $bbox] == 4} {
 191     set selidx [eval $c create rectangle $bbox -fill $::Colors(sbg) -outline {{}}]
 192     $c lower $selidx
 193   } else {
 194     set selidx {}
 195   }
 196 }
 197
 198 # button 1 callback
 199 itcl::body  VarTree::clicked {w x y open} {
 200   #debug "clicked $w $x $y $open"
 201   set x [$w canvasx $x]
 202   set y [$w canvasy $y]
 203   foreach m [$w find overlapping $x $y $x $y] {
 204     if {[info exists item_to_var($m)]} {
 205       if {$open} {
 206         set var $item_to_var($m)
 207         if {[closed $var]} {
 208           set closed($var) 0
 209         } else {
 210           set closed($var) 1
 211         }
 212         after idle [code $this build]
 213       } else {
 214         setselection $item_to_var($m)
 215       }
 216       return
 217     }
 218   }
 219   if {!$open} {
 220     setselection ""
 221   }
 222 }
 223
 224
 225 #
 226 # Change the selection to the indicated item
 227 #
 228 itcl::body  VarTree::setselection {var} {
 229   #debug "setselection $var"
 230   set selection $var
 231   drawselection
 232 }
 233
 234 # Check if a node is closed.
 235 # If it is a new node, set it to closed
 236 itcl::body  VarTree::closed {name} {
 237   if {![info exists closed($name)]} {
 238     set closed($name) 1
 239   }
 240   return $closed($name)
 241 }
 242
 243 # mark a node open
 244 itcl::body  VarTree::open {name} {
 245   set closed($name) 0
 246   after idle [code $this build]
 247 }
 248
 249 # mark a node closed
 250 itcl::body  VarTree::close {name} {
 251   set closed($name) 1
 252   after idle [code $this build]
 253 }
 254
 255 # edit a varobj.
 256 # creates an entry widget in place of the current value
 257 itcl::body  VarTree::edit {j} {
 258   #debug "$j"
 259
 260   # if another edit is in progress, cancel it
 261   if {$entry != ""} { unedit $j }
 262
 263   set entryobj $item_to_var($j)
 264   set entry [entry $c.entry  -bg $::Colors(bg) -fg $::Colors(fg) -font global/fixed]
 265   set entrywin [$c create window [$c coords $j] -window $entry -anchor w]
 266   focus $entry
 267   bind $entry <Return> [code $this changeValue $j]
 268   bind $entry <Escape> [code $this unedit $j]
 269 }
 270
 271 # cancel or clean up after an edit
 272 itcl::body  VarTree::unedit {j} {
 273   #debug
 274   # cancel the edit
 275   $c delete $entrywin
 276   destroy $entry
 277   set entry ""
 278   $c raise $j
 279 }
 280
 281 # change the value of a varobj.
 282 itcl::body  VarTree::changeValue {j} {
 283   #debug "value = [$entry get]"
 284   set new [string trim [$entry get] \ \r\n]
 285   if {$new == ""} {
 286     unedit $j
 287     return
 288   }
 289   if {[catch {$entryobj value $new} errTxt]} {
 290     # gdbtk-varobj doesn't actually return meaningful error messages
 291     # so use a generic one.
 292     set errTxt "GDB could not evaluate that expression"
 293     tk_messageBox -icon error -type ok -message $errTxt \
 294       -title "Error in Expression" -parent [winfo toplevel $itk_interior]
 295     focus $entry
 296     $entry selection to end
 297   } else {
 298     unedit $j
 299
 300     # We may have changed a register or something else that is
 301     # being displayed in another window
 302     gdbtk_update
 303   }
 304 }
 305
 306 # change the format for a var
 307 itcl::body  VarTree::_change_format {var} {
 308   #debug "$var $popup_temp"
 309   catch {$var format $popup_temp}
 310   after idle [code $this update]
 311 }
 312
 313 # button 3 callback.  Pops up a menu.
 314 itcl::body  VarTree::_but3 {x y X Y} {
 315   set x [$c canvasx $x]
 316   set y [$c canvasy $y]
 317   catch {destroy $pop.format}
 318
 319   set var ""
 320   foreach item [$c find overlapping $x $y $x $y] {
 321     if {![catch {set var $item_to_var($item)}]} {
 322       break
 323     }
 324   }
 325   setselection $var
 326   if {$var == ""} {
 327     _do_default_menu $X $Y
 328     return
 329   }
 330   set popup_temp [$var format]
 331   set j3 [lindex $var_to_items($var) 2]
 332   #debug "var=$var [$var name] format=$popup_temp  this=$this"
 333   $pop delete 0 end
 334   $pop add command -label [$var name] -state disabled
 335   $pop add separator
 336   $pop add cascade -menu $pop.format -label "Format" -underline 0
 337   set f [menu $pop.format -tearoff 0]
 338   $f add radio -label "Natural" -variable [scope popup_temp] -value "natural" -command [code $this _change_format $var]
 339   $f add radio -label "Decimal" -variable [scope popup_temp] -value "decimal" -command [code $this _change_format $var]
 340   $f add radio -label "Hex" -variable [scope popup_temp] -value "hexadecimal" -command [code $this _change_format $var]
 341   $f add radio -label "Octal" -variable [scope popup_temp] -value "octal" -command [code $this _change_format $var]
 342   $f add radio -label "Binary" -variable [scope popup_temp] -value "binary" -command [code $this _change_format $var]
 343   $pop add command -label "Edit" -command [code $this edit $j3]
 344   $pop add command -label "Delete" -command [code $this remove $var]
 345   if {![catch {$var value} value]} {
 346     $pop add separator
 347     $pop add command -label "Dump Memory at [$var name]" -command [list ManagedWin::open MemWin -force -addr_exp [$var name]]
 348   }
 349   $pop add separator
 350   if {$type == "local"} {
 351     $pop add command -label "Help" -command "open_help watch.html"
 352   } else {
 353     $pop add command -label "Help" -command "open_help locals.html"
 354   }
 355   $pop add separator
 356   $pop add command -label "Close" -command "destroy [winfo toplevel $itk_interior]"
 357   tk_popup $pop $X $Y
 358 }
 359
 360 # popup menu over empty space
 361 itcl::body  VarTree::_do_default_menu {X Y} {
 362   #debug
 363   $pop delete 0 end
 364   if {$type == "local"} {
 365     $pop add command -label "Local Variables" -state disabled
 366   } else {
 367     $pop add command -label "Watch Window" -state disabled
 368   }
 369   $pop add separator
 370   $pop add command -label "Sort" -command [code $this _sort]
 371   if {$type == "local"} {
 372     $pop add command -label "Help" -command "open_help watch.html"
 373   } else {
 374     $pop add command -label "Help" -command "open_help locals.html"
 375   }
 376   $pop add separator
 377   $pop add command -label "Close" -command "destroy [winfo toplevel $itk_interior]"
 378   tk_popup $pop $X $Y
 379 }
 380
 381 # alphabetize the variable names in the list
 382 itcl::body  VarTree::_sort {} {
 383   #debug $rootlist
 384   set rootlist [lsort -command [code $this _compare] $rootlist]
 385   after idle [code $this build]
 386 }
 387
 388 # comparison function for lsort.
 389 itcl::body  VarTree::_compare {a b} {
 390   return [string compare [$a name] [$b name]]
 391 }
 392
 393 # ititialize common data
 394 itcl::body  VarTree::_init_data {} {
 395   set colors(name) "\#0000C0"
 396   set colors(type) "red"
 397   set colors(error) "red"
 398   set colors(value) "black"
 399   set colors(change) $::Colors(change)
 400   set colors(disabled) "gray50"
 401   set colors(line) "gray50"
 402
 403   set maskdata "#define solid_width 9\n#define solid_height 9"
 404   append maskdata {
 405     static unsigned char solid_bits[] = {
 406       0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01,
 407       0xff, 0x01, 0xff, 0x01, 0xff, 0x01
 408     };
 409   }
 410   set data "#define open_width 9\n#define open_height 9"
 411   append data {
 412     static unsigned char open_bits[] = {
 413       0xff, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x7d, 0x01, 0x01, 0x01,
 414       0x01, 0x01, 0x01, 0x01, 0xff, 0x01
 415     };
 416   }
 417   image create bitmap openbm -data $data -maskdata $maskdata \
 418     -foreground black -background white
 419   set data "#define closed_width 9\n#define closed_height 9"
 420   append data {
 421     static unsigned char closed_bits[] = {
 422       0xff, 0x01, 0x01, 0x01, 0x11, 0x01, 0x11, 0x01, 0x7d, 0x01, 0x11, 0x01,
 423       0x11, 0x01, 0x01, 0x01, 0xff, 0x01
 424     };
 425   }
 426   image create bitmap closedbm -data $data -maskdata $maskdata \
 427     -foreground black -background white
 428
 429   set initialized 1
 430 }
 431