# Variable tree implementation for Insight.
# Copyright 2002 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 (GPL) 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.
itcl::body VarTree::constructor {args} {
debug $args
if {!$initialized} {
_init_data
}
eval itk_initialize $args
itk_component add canvas {
iwidgets::scrolledcanvas $itk_interior.c -autoresize 1 -hscrollmode dynamic -vscrollmode dynamic \
-background $::Colors(textbg) -borderwidth 0 -highlightthickness 0
}
set c [$itk_component(canvas) childsite]
pack $itk_component(canvas) -side top -fill both -expand 1
bind $c <1> "[code $this clicked %W %x %y 0]"
# Add popup menu - we populate it in _but3
itk_component add popup {
menu $itk_interior.pop -tearoff 0
} {}
set pop $itk_component(popup)
$pop configure -disabledforeground $::Colors(fg)
bind $c <3> [code $this _but3 %x %y %X %Y]
set selection {}
set selidx {}
after idle [code $this build]
}
itcl::body VarTree::destructor {} {
debug
}
itcl::body VarTree::build {} {
debug
$c delete all
catch {unset var_to_items}
catch {unset item_to_var}
set _y 30
buildlayer $rootlist 10
$c config -scrollregion [$c bbox all] -background $::Colors(textbg) -borderwidth 0 -highlightthickness 0
update 1
drawselection
}
itcl::body VarTree::buildlayer {tlist in} {
set start [expr $_y - 10]
foreach var $tlist {
set y $_y
incr _y 17
if {$in > 10} {
$c create line $in $y [expr $in+10] $y -fill $colors(line)
}
set x [expr $in + 12]
set j1 [$c create text $x $y -text "[$var name] = " -fill $colors(name) -anchor w -font global/fixed]
set x [expr [lindex [$c bbox $j1] 2] + 5]
set j2 [$c create text $x $y -text "([$var type])" -fill $colors(type) -anchor w -font global/fixed]
set x [expr [lindex [$c bbox $j2] 2] + 5]
if {[catch {$var value} val]} {
# error accessing memory, etc.
set j3 [$c create text $x $y -text $val -fill $colors(error) -anchor w -font global/fixed]
} else {
set j3 [$c create text $x $y -text $val -fill $colors(value) -anchor w -font global/fixed]
}
set var_to_items($var) [list $j1 $j2 $j3]
set item_to_var($j1) $var
set item_to_var($j2) $var
set item_to_var($j3) $var
$c bind $j1 <Double-1> "[code $this clicked %W %x %y 1]"
$c bind $j2 <Double-1> "[code $this clicked %W %x %y 1]"
$c bind $j3 <Double-1> "[code $this edit $j3];break"
if {[$var numChildren]} {
if {[closed $var]} {
set j [$c create image $in $y -image closedbm]
$c bind $j <1> "[code $this open $var]"
} else {
set j [$c create image $in $y -image openbm]
$c bind $j <1> "[code $this close $var]"
buildlayer [$var children] [expr $in+18]
}
}
}
if {$in > 10} {
$c lower [$c create line $in $start $in [expr $y+1] -fill $colors(line) ]
}
}
# add: add a list of varobj to the tree
itcl::body VarTree::add {var} {
debug $var
if {$var == ""} {return}
set rootlist [concat $rootlist $var]
after idle [code $this build]
}
# remove: remove a varobj from the tree
# if the name is "all" then remove all
itcl::body VarTree::remove {name} {
debug $name
if {$name == ""} {return}
if {$name == "all"} {
set rootlist {}
} else {
set rootlist [lremove $rootlist $name]
}
after idle [code $this build]
}
# update a var
itcl::body VarTree::update_var {var enabled check} {
if {$enabled && $check} {return}
lassign $var_to_items($var) nam typ val
if {$enabled} {
$c itemconfigure $nam -fill $colors(name)
$c itemconfigure $typ -fill $colors(type)
if {[catch {$var value} value]} {
set color $colors(error)
} elseif {[$c itemcget $val -text] != $value} {
set color $colors(change)
} else {
set color $colors(value)
}
$c itemconfigure $val -text $value -fill $color
} else {
$c itemconfigure $nam -fill $colors(disabled)
$c itemconfigure $typ -fill $colors(disabled)
$c itemconfigure $val -fill $colors(disabled)
}
if {![closed $var] && [$var numChildren]} {
foreach child [$var children] {
update_var $child $enabled $check
}
}
}
# update: update the values of the vars in the tree.
# The "check" argument is a hack we have to do because
# [$varobj value] does not return an error; only [$varobj update]
# does. So after changing the tree layout in build, we must then
# do an update. The "check" argument just optimizes things a bit over
# a normal update by not fetching values, just calling update.
itcl::body VarTree::update {{check 0}} {
debug
# delete selection box if it is visible
if {$selidx != ""} {
$c delete $selidx
}
# update all the root variables
foreach var $rootlist {
if {[$var update] == "-1"} {
set enabled 0
} else {
set enabled 1
}
update_var $var $enabled $check
}
}
# Draw the selection highlight
itcl::body VarTree::drawselection {} {
#debug "selidx=$selidx selection=$selection"
if {$selidx != ""} {
$c delete $selidx
}
if {$selection == ""} return
if {![info exists var_to_items($selection)]} return
set bbox [eval "$c bbox $var_to_items($selection)"]
if {[llength $bbox] == 4} {
set selidx [eval $c create rectangle $bbox -fill $::Colors(sbg) -outline {{}}]
$c lower $selidx
} else {
set selidx {}
}
}
# button 1 callback
itcl::body VarTree::clicked {w x y open} {
#debug "clicked $w $x $y $open"
set x [$w canvasx $x]
set y [$w canvasy $y]
foreach m [$w find overlapping $x $y $x $y] {
if {[info exists item_to_var($m)]} {
if {$open} {
set var $item_to_var($m)
if {[closed $var]} {
set closed($var) 0
} else {
set closed($var) 1
}
after idle [code $this build]
} else {
setselection $item_to_var($m)
}
return
}
}
if {!$open} {
setselection ""
}
}
#
# Change the selection to the indicated item
#
itcl::body VarTree::setselection {var} {
#debug "setselection $var"
set selection $var
drawselection
}
# Check if a node is closed.
# If it is a new node, set it to closed
itcl::body VarTree::closed {name} {
if {![info exists closed($name)]} {
set closed($name) 1
}
return $closed($name)
}
# mark a node open
itcl::body VarTree::open {name} {
set closed($name) 0
after idle [code $this build]
}
# mark a node closed
itcl::body VarTree::close {name} {
set closed($name) 1
after idle [code $this build]
}
# edit a varobj.
# creates an entry widget in place of the current value
itcl::body VarTree::edit {j} {
#debug "$j"
# if another edit is in progress, cancel it
if {$entry != ""} { unedit $j }
set entryobj $item_to_var($j)
set entry [entry $c.entry -bg $::Colors(bg) -fg $::Colors(fg) -font global/fixed]
set entrywin [$c create window [$c coords $j] -window $entry -anchor w]
focus $entry
bind $entry <Return> [code $this changeValue $j]
bind $entry <Escape> [code $this unedit $j]
}
# cancel or clean up after an edit
itcl::body VarTree::unedit {j} {
#debug
# cancel the edit
$c delete $entrywin
destroy $entry
set entry ""
$c raise $j
}
# change the value of a varobj.
itcl::body VarTree::changeValue {j} {
#debug "value = [$entry get]"
set new [string trim [$entry get] \ \r\n]
if {$new == ""} {
unedit $j
return
}
if {[catch {$entryobj value $new} errTxt]} {
# gdbtk-varobj doesn't actually return meaningful error messages
# so use a generic one.
set errTxt "GDB could not evaluate that expression"
tk_messageBox -icon error -type ok -message $errTxt \
-title "Error in Expression" -parent [winfo toplevel $itk_interior]
focus $entry
$entry selection to end
} else {
unedit $j
# We may have changed a register or something else that is
# being displayed in another window
gdbtk_update
}
}
# change the format for a var
itcl::body VarTree::_change_format {var} {
#debug "$var $popup_temp"
catch {$var format $popup_temp}
after idle [code $this update]
}
# button 3 callback. Pops up a menu.
itcl::body VarTree::_but3 {x y X Y} {
set x [$c canvasx $x]
set y [$c canvasy $y]
catch {destroy $pop.format}
set var ""
foreach item [$c find overlapping $x $y $x $y] {
if {![catch {set var $item_to_var($item)}]} {
break
}
}
setselection $var
if {$var == ""} {
_do_default_menu $X $Y
return
}
set popup_temp [$var format]
set j3 [lindex $var_to_items($var) 2]
#debug "var=$var [$var name] format=$popup_temp this=$this"
$pop delete 0 end
$pop add command -label [$var name] -state disabled
$pop add separator
$pop add cascade -menu $pop.format -label "Format" -underline 0
set f [menu $pop.format -tearoff 0]
$f add radio -label "Natural" -variable [scope popup_temp] -value "natural" -command [code $this _change_format $var]
$f add radio -label "Decimal" -variable [scope popup_temp] -value "decimal" -command [code $this _change_format $var]
$f add radio -label "Hex" -variable [scope popup_temp] -value "hexadecimal" -command [code $this _change_format $var]
$f add radio -label "Octal" -variable [scope popup_temp] -value "octal" -command [code $this _change_format $var]
$f add radio -label "Binary" -variable [scope popup_temp] -value "binary" -command [code $this _change_format $var]
$pop add command -label "Edit" -command [code $this edit $j3]
$pop add command -label "Delete" -command [code $this remove $var]
if {![catch {$var value} value]} {
$pop add separator
$pop add command -label "Dump Memory at [$var name]" -command [list ManagedWin::open MemWin -force -addr_exp [$var name]]
}
$pop add separator
if {$type == "local"} {
$pop add command -label "Help" -command "open_help watch.html"
} else {
$pop add command -label "Help" -command "open_help locals.html"
}
$pop add separator
$pop add command -label "Close" -command "destroy [winfo toplevel $itk_interior]"
tk_popup $pop $X $Y
}
# popup menu over empty space
itcl::body VarTree::_do_default_menu {X Y} {
#debug
$pop delete 0 end
if {$type == "local"} {
$pop add command -label "Local Variables" -state disabled
} else {
$pop add command -label "Watch Window" -state disabled
}
$pop add separator
$pop add command -label "Sort" -command [code $this _sort]
if {$type == "local"} {
$pop add command -label "Help" -command "open_help watch.html"
} else {
$pop add command -label "Help" -command "open_help locals.html"
}
$pop add separator
$pop add command -label "Close" -command "destroy [winfo toplevel $itk_interior]"
tk_popup $pop $X $Y
}
# alphabetize the variable names in the list
itcl::body VarTree::_sort {} {
#debug $rootlist
set rootlist [lsort -command [code $this _compare] $rootlist]
after idle [code $this build]
}
# comparison function for lsort.
itcl::body VarTree::_compare {a b} {
return [string compare [$a name] [$b name]]
}
# ititialize common data
itcl::body VarTree::_init_data {} {
set colors(name) "\#0000C0"
set colors(type) "red"
set colors(error) "red"
set colors(value) "black"
set colors(change) $::Colors(change)
set colors(disabled) "gray50"
set colors(line) "gray50"
set maskdata "#define solid_width 9\n#define solid_height 9"
append maskdata {
static unsigned char solid_bits[] = {
0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01,
0xff, 0x01, 0xff, 0x01, 0xff, 0x01
};
}
set data "#define open_width 9\n#define open_height 9"
append data {
static unsigned char open_bits[] = {
0xff, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x7d, 0x01, 0x01, 0x01,
0x01, 0x01, 0x01, 0x01, 0xff, 0x01
};
}
image create bitmap openbm -data $data -maskdata $maskdata \
-foreground black -background white
set data "#define closed_width 9\n#define closed_height 9"
append data {
static unsigned char closed_bits[] = {
0xff, 0x01, 0x01, 0x01, 0x11, 0x01, 0x11, 0x01, 0x7d, 0x01, 0x11, 0x01,
0x11, 0x01, 0x01, 0x01, 0xff, 0x01
};
}
image create bitmap closedbm -data $data -maskdata $maskdata \
-foreground black -background white
set initialized 1
}