diff options
Diffstat (limited to 'gdb/gdbtk/library/vartree.itb')
| -rw-r--r-- | gdb/gdbtk/library/vartree.itb | 431 |
1 files changed, 0 insertions, 431 deletions
diff --git a/gdb/gdbtk/library/vartree.itb b/gdb/gdbtk/library/vartree.itb deleted file mode 100644 index 57d0c3228d5..00000000000 --- a/gdb/gdbtk/library/vartree.itb +++ /dev/null @@ -1,431 +0,0 @@ -# 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 -} - |