| # Variable tree implementation for Insight. |
| # Copyright (C) 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 |
| } |
| |