* library/watch.tcl: Completely rewritten to use VarTree.
* library/locals.tcl: Completely rewritten to use VarTree.
* library/variables.tcl: Deleted.
* library/vartree.ith: New file.
* library/vartree.itb: New file. Implements a variable
tree.
* library/tclIndex: Rebuilt.
2002-11-06 Martin M. Hunt <hunt@redhat.com>
+ * library/watch.tcl: Completely rewritten to use VarTree.
+ * library/locals.tcl: Completely rewritten to use VarTree.
+ * library/variables.tcl: Deleted.
+ * library/vartree.ith: New file.
+ * library/vartree.itb: New file. Implements a variable
+ tree.
+ * library/tclIndex: Rebuilt.
+
+2002-11-06 Martin M. Hunt <hunt@redhat.com>
* library/globalpref.itb (_build_win): Add radiobox
to select KDE/GNOME/default for pref gdb/compat. Remove
browser option.
-# Local variable window for Insight.
-# Copyright 1997, 1998, 1999, 2001 Red Hat
+# Local Variable Window for Insight.
+# Copyright 2002 Red Hat
#
# 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
# GNU General Public License for more details.
-itcl::class LocalsWin {
- inherit VariableWin
-
- # ------------------------------------------------------------------
- # CONSTRUCTOR - create new locals window
- # ------------------------------------------------------------------
- constructor {args} {
- update dummy
- }
-
- # ------------------------------------------------------------------
- # DESTRUCTOR - delete locals window
- # ------------------------------------------------------------------
- destructor {
- }
-
- method build_win {f} {
- global tcl_platform
- build_menu_helper Variable
- if {$tcl_platform(platform) == "windows"} {
- frame $f.f
- VariableWin::build_win $f.f
- pack $f.f -expand yes -fill both -side top
- frame $f.stat
- pack $f.stat -side bottom -fill x
- } else {
- VariableWin::build_win $f
- }
- }
-
+# ----------------------------------------------------------------------
+# Implements local variables windows for gdb.
+# ----------------------------------------------------------------------
- # ------------------------------------------------------------------
- # METHOD: reconfig
- # Overrides VarialbeWin::reconfig method. Have to make sure the locals
- # will get redrawn after everything is destroyed...
- # ------------------------------------------------------------------
- method reconfig {} {
- VariableWin::reconfig
- populate {}
+itcl::class LocalsWin {
+ inherit EmbeddedWin GDBWin
+ # ------------------------------------------------------------------
+ # CONSTRUCTOR - create new locals window
+ # ------------------------------------------------------------------
+ constructor {args} {
+ debug
+
+ gdbtk_busy
+ build_win $itk_interior
+ gdbtk_idle
+
+ add_hook gdb_no_inferior_hook "$this no_inferior"
+ add_hook gdb_clear_file_hook [code $this clear_file]
+ add_hook file_changed_hook [code $this clear_file]
+
+ update dummy
+ }
+
+
+ # ------------------------------------------------------------------
+ # PUBLIC METHOD: busy - BusyEvent handler
+ # Disable all ui elements that could affect gdb's state
+ # ------------------------------------------------------------------
+ method busy {event} {
+ debug
+ set Running 1
+ cursor watch
+ }
+
+ # Re-enable the UI
+ method idle {event} {
+ debug
+ set Running 0
+ cursor {}
+ }
+
+ # ------------------------------------------------------------------
+ # METHOD: no_inferior
+ # Reset this object.
+ # ------------------------------------------------------------------
+ method no_inferior {} {
+ debug
+ cursor {}
+ set Running 0
+ set _frame {}
+ }
+
+ # ------------------------------------------------------------------
+ # METHOD: cursor - change the toplevel's cursor
+ # ------------------------------------------------------------------
+ method cursor {what} {
+ [winfo toplevel [namespace tail $this]] configure -cursor $what
+ ::update idletasks
+ }
+
+
+ # ------------------------------------------------------------------
+ # METHOD: build_win - build window for variables.
+ # ------------------------------------------------------------------
+ method build_win {f} {
+ #debug "$f"
+
+ if {$::tcl_platform(platform) == "windows"} {
+ frame $f.f
+ set tree [VarTree $f.f -type "local"]
+ pack $f.f -expand yes -fill both -side top
+ frame $f.stat
+ pack $f.stat -side bottom -fill x
+ } else {
+ set tree [VarTree $f.tree -type "local"]
}
- # ------------------------------------------------------------------
- # METHOD: getVariablesBlankPath
- # Overrides VarialbeWin::getVariablesBlankPath. For a Locals Window,
- # this method returns a list of local variables.
- # ------------------------------------------------------------------
- method getVariablesBlankPath {} {
- global Update
- debug
-
- return [$_frame variables]
+ pack $f.tree -expand yes -fill both
+ pack $f -expand yes -fill both
+
+ window_name "Local Variables"
+ ::update idletasks
+ }
+
+
+ # ------------------------------------------------------------------
+ # METHOD: clear_file - Clear out state so that a new executable
+ # can be loaded. For LocalWins, this means deleting
+ # the Variables list.
+ # ------------------------------------------------------------------
+ method clear_file {} {
+ debug
+ set Variables {}
+ }
+
+ # ------------------------------------------------------------------
+ # DESTRUCTOR - delete locals window
+ # ------------------------------------------------------------------
+ destructor {
+ debug
+ set tree {}
+
+ # Remove this window and all hooks
+ remove_hook gdb_no_inferior_hook "$this no_inferior"
+ remove_hook gdb_clear_file_hook [code $this clear_file]
+ remove_hook file_changed_hook [code $this clear_file]
+
+ foreach var $Variables {
+ $var delete
}
-
- method update {event} {
- global Update Display
-
- debug "START LOCALS UPDATE CALLBACK"
- # Check that a context switch has not occured
- if {[context_switch]} {
- debug "CONTEXT SWITCH"
-
- # our context has changed... repopulate with new variables
- # destroy the old tree and create a new one
- #
- # We need to be more intelligent about saving window state
- # when browsing the stack or stepping into new frames, but
- # for now, we'll have to settle for just getting this working.
- deleteTree
- set ChangeList {}
-
- # context_switch will have already created the new frame for
- # us, so all we need to do is shove stuff into the window.
- debug "_frame=$_frame"
- if {$_frame != ""} {
- debug "vars=[$_frame variables]"
- }
- if {$_frame != "" && [$_frame variables] != ""} {
- populate {}
- }
- }
-
- # Erase old variables
- if {$_frame != ""} {
- foreach var [$_frame old] {
- $Hlist delete entry $var
- $_frame deleteOld
- unset Update($this,$var)
- }
-
- # Add new variables
- foreach var [$_frame new] {
- set Update($this,$var) 1
- $Hlist add $var \
- -itemtype text \
- -text [label $var]
- if {[$var numChildren] > 0} {
- # Make sure we get this labeled as openable
- $Tree setmode $var open
- }
- }
- }
-
- # Update variables in window
- VariableWin::update dummy
-
- debug "END LOCALS UPDATE CALLBACK"
+ }
+
+ method context_switch {} {
+ debug
+
+ set err [catch {gdb_selected_frame} current_frame]
+ #debug "1: err=$err; _frame=\"$_frame\"; current_frame=\"$current_frame\""
+
+ if {$err && $_frame != ""} {
+ # No current frame
+ debug "no current frame"
+ catch {destroy $_frame}
+ set _frame {}
+ return 1
+ } elseif {$current_frame == "" && $_frame == ""} {
+ #debug "2"
+ return 0
+ } elseif {$_frame == "" || $current_frame != [$_frame address]} {
+ # We've changed frames. If we knew something about
+ # the stack layout, we could be more intelligent about
+ # destroying variables, but we don't know that here (yet).
+ debug "switching to frame at $current_frame"
+
+ # Destroy the old frame and create the new one
+ catch {destroy $_frame}
+ set _frame [Frame ::\#auto $current_frame]
+ debug "created new frame: $_frame at [$_frame address]"
+ return 1
}
+
+ # Nothing changed
+ #debug "3"
+ return 0
+ }
+
+
+ method update {event} {
+ debug
+
+ # Check that a context switch has not occured
+ if {[context_switch]} {
+ debug "CONTEXT SWITCH"
+
+ # delete variables in tree
+ $tree remove all
+ set Variables {}
+
+ if {$_frame != ""} {
+ $tree add [$_frame variables]
+ }
+ } else {
+ if {$_frame == ""} {return}
+ # check for any new variables in the same frame
+ $tree add [$_frame new]
+ }
+ after idle [code $tree update]
+ }
+
+ protected variable Entry
+ protected variable Variables {}
+ protected variable tree
+ protected variable Running
+ protected variable _frame {}
}
-
set auto_index(unescape_value) [list source [file join $dir prefs.tcl]]
set auto_index(pref_set_defaults) [list source [file join $dir prefs.tcl]]
set auto_index(pref_set_colors) [list source [file join $dir prefs.tcl]]
+set auto_index(pref_load_default) [list source [file join $dir prefs.tcl]]
+set auto_index(pref_load_gnome) [list source [file join $dir prefs.tcl]]
+set auto_index(load_gnome_file) [list source [file join $dir prefs.tcl]]
+set auto_index(pref_set_option_db) [list source [file join $dir prefs.tcl]]
set auto_index(::Session::_exe_name) [list source [file join $dir session.tcl]]
set auto_index(::Session::_serialize_bps) [list source [file join $dir session.tcl]]
set auto_index(::Session::_recreate_bps) [list source [file join $dir session.tcl]]
set auto_index(StackWin) [list source [file join $dir stackwin.ith]]
set auto_index(TargetSelection) [list source [file join $dir targetselection.ith]]
set auto_index(TopLevelWin) [list source [file join $dir toplevelwin.ith]]
+set auto_index(VarTree) [list source [file join $dir vartree.ith]]
set auto_index(::AttachDlg::constructor) [list source [file join $dir attachdlg.itb]]
set auto_index(::AttachDlg::build_win) [list source [file join $dir attachdlg.itb]]
set auto_index(::AttachDlg::doit) [list source [file join $dir attachdlg.itb]]
set auto_index(::TargetSelection::target_trace) [list source [file join $dir targetselection.itb]]
set auto_index(::TargetSelection::valid_target) [list source [file join $dir targetselection.itb]]
set auto_index(::TargetSelection::native_debugging) [list source [file join $dir targetselection.itb]]
+set auto_index(::VarTree::constructor) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::destructor) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::build) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::buildlayer) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::add) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::remove) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::update_var) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::update) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::drawselection) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::clicked) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::setselection) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::closed) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::open) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::close) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::edit) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::unedit) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::changeValue) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::_change_format) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::_but3) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::_do_default_menu) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::_sort) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::_compare) [list source [file join $dir vartree.itb]]
+set auto_index(::VarTree::_init_data) [list source [file join $dir vartree.itb]]
+++ /dev/null
-# Variable display window for Insight.
-# Copyright 1997, 1998, 1999, 2001, 2002 Red Hat
-#
-# 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.
-
-
-# ----------------------------------------------------------------------
-# Implements variable windows for gdb. LocalsWin and WatchWin both
-# inherit from this class. You need only override the method
-# 'getVariablesBlankPath' and a few other things...
-# ----------------------------------------------------------------------
-
-itcl::class VariableWin {
- inherit EmbeddedWin GDBWin
- protected variable Sizebox 1
-
- # ------------------------------------------------------------------
- # CONSTRUCTOR - create new watch window
- # ------------------------------------------------------------------
- constructor {args} {
- #
- # Create a window with the same name as this object
- #
- gdbtk_busy
- set _queue [Queue \#auto]
- build_win $itk_interior
- gdbtk_idle
-
- add_hook gdb_no_inferior_hook "$this no_inferior"
- add_hook gdb_clear_file_hook [code $this clear_file]
- # FIXME: This is too harsh. We must add to varobj a method
- # to re-parse the expressions and compute new types so we can
- # keep the contents of the window whenever possible.
- add_hook file_changed_hook [code $this clear_file]
- }
-
- # ------------------------------------------------------------------
- # METHOD: build_win - build the watch window
- # ------------------------------------------------------------------
- method build_win {f} {
- global tcl_platform Display
- # debug
- set width [font measure global/fixed "W"]
- # Choose the default width to be...
- set width [expr {40 * $width}]
- if {$tcl_platform(platform) == "windows"} {
- set scrollmode both
- } else {
- set scrollmode auto
- }
-
- debug "tree=$f.tree"
- set Tree [tixTree $f.tree \
- -opencmd "$this open" \
- -closecmd "$this close" \
- -ignoreinvoke 1 \
- -width $width \
- -browsecmd [list $this selectionChanged] \
- -scrollbar $scrollmode \
- -sizebox $Sizebox]
- if {![pref get gdb/mode]} {
- $Tree configure -command [list $this editEntry]
- }
- set Hlist [$Tree subwidget hlist]
-
- # FIXME: probably should use columns instead.
- $Hlist configure -header 1
-
- set l [expr {$EntryLength - $Length - [string length "Name"]}]
- # Ok, this is as hack as it gets
- set blank " "
- $Hlist header create 0 -itemtype text -headerbackground $::Colors(bg) \
- -text "Name[string range $blank 0 $l]Value"
-
- # Configure the look of the tree
- set width [font measure global/fixed $LengthString]
- $Hlist configure -indent $width \
- -bg $::Colors(textbg) -fg $::Colors(textfg) \
- -selectforeground $::Colors(textfg) -selectbackground $::Colors(textbg) \
- -selectborderwidth 0 -separator . -font global/fixed
-
- # Get display styles
- set normal_fg [$Hlist cget -fg]
- set highlight_fg $::Colors(sfg)
- set disabled_fg red
- set NormalTextStyle [tixDisplayStyle text -refwindow $Hlist \
- -bg $::Colors(textbg) -font global/fixed]
- set HighlightTextStyle [tixDisplayStyle text -refwindow $Hlist \
- -bg $::Colors(hbg) -font global/fixed]
- set DisabledTextStyle [tixDisplayStyle text -refwindow $Hlist \
- -bg green -fg red -font global/fixed]
-
- if {[catch {gdb_cmd "show output-radix"} msg]} {
- set Radix 10
- } else {
- regexp {[0-9]+} $msg Radix
- }
-
-
- # Update the tree display
- update dummy
- pack $Tree -expand yes -fill both
-
- # Create the popup menu for this widget
- bind $Hlist <3> "$this postMenu %X %Y"
- bind $Hlist <KeyPress-space> [code $this toggleView]
-
- # Do not use the tixPopup widget...
- set Popup [menu $f.menu -tearoff 0]
- set disabled_foreground red
- $Popup configure -disabledforeground $disabled_foreground
- set ViewMenu [menu $Popup.view]
-
- # Populate the view menu
- $ViewMenu add radiobutton -label "Hex" -variable Display($this) \
- -value hexadecimal
- $ViewMenu add radiobutton -label "Decimal" -variable Display($this) \
- -value decimal
- $ViewMenu add radiobutton -label "Binary" -variable Display($this) \
- -value binary
- $ViewMenu add radiobutton -label "Octal" -variable Display($this) \
- -value octal
- $ViewMenu add radiobutton -label "Natural" -variable Display($this) \
- -value natural
-
- $Popup add command -label "dummy" -state disabled
- $Popup add separator
- $Popup add cascade -label "Format" -menu $ViewMenu
- # $Popup add checkbutton -label "Auto Update"
- # $Popup add command -label "Update Now"
- if {![pref get gdb/mode]} {
- $Popup add command -label "Edit"
- }
-
- # Make sure to update menu info.
- selectionChanged ""
-
- window_name "Local Variables" "Locals"
- }
-
- # ------------------------------------------------------------------
- # DESTRUCTOR - destroy window containing widget
- # ------------------------------------------------------------------
- destructor {
- # debug
- # Make sure to clean up the frame
- catch {destroy $_frame}
-
- # Delete the display styles used with this window
- destroy $NormalTextStyle
- destroy $HighlightTextStyle
- destroy $DisabledTextStyle
-
- # Remove this window and all hooks
- remove_hook gdb_no_inferior_hook "$this no_inferior"
- remove_hook gdb_clear_file_hook [code $this clear_file]
- remove_hook file_changed_hook [code $this clear_file]
- }
-
- # ------------------------------------------------------------------
- # METHOD: clear_file - Clear out state and prepare for loading
- # a new executable.
- # ------------------------------------------------------------------
- method clear_file {} {
- no_inferior
- }
-
- # ------------------------------------------------------------------
- # METHOD: reconfig - used when preferences change
- # ------------------------------------------------------------------
- method reconfig {} {
- # debug
- foreach win [winfo children $itk_interior] {
- destroy $win
- }
-
- build_win $itk_interior
- }
-
- # ------------------------------------------------------------------
- # METHOD: build_menu_helper - Create the menu for a subclass.
- # ------------------------------------------------------------------
- method build_menu_helper {first} {
- global Display
- menu [namespace tail $this].mmenu
-
- [namespace tail $this].mmenu add cascade -label $first -underline 0 -menu [namespace tail $this].mmenu.var
-
- menu [namespace tail $this].mmenu.var
- if {![pref get gdb/mode]} {
- [namespace tail $this].mmenu.var add command -label Edit -underline 0 -state disabled \
- -command [format {
- %s editEntry [%s getSelection]
- } $this $this]
- }
- [namespace tail $this].mmenu.var add cascade -label Format -underline 0 -state disabled \
- -menu [namespace tail $this].mmenu.var.format
-
- menu [namespace tail $this].mmenu.var.format
- foreach label {Hex Decimal Binary Octal Natural} fmt {hexadecimal decimal binary octal natural} {
- [namespace tail $this].mmenu.var.format add radiobutton \
- -label $label -underline 0 \
- -value $fmt -variable Display($this) \
- -command [format {
- %s setDisplay [%s getSelection] %s
- } $this $this $fmt]
- }
-
- # [namespace tail $this].mmenu add cascade -label Update -underline 0 -menu [namespace tail $this].mmenu.update
- # menu [namespace tail $this].mmenu.update
-
- # The -variable is set when a selection is made in the tree.
- # [namespace tail $this].mmenu.update add checkbutton -label "Auto Update" -underline 0 \
- # -command [format {
- # %s toggleUpdate [%s getSelection]
- # } $this $this]
- # [namespace tail $this].mmenu.update add command -label "Update Now" -underline 0 \
- # -accelerator "Ctrl+U" -command [format {
- # %s updateNow [%s getSelection]
- # } $this $this]
-
- set top [winfo toplevel [namespace tail $this]]
- $top configure -menu [namespace tail $this].mmenu
- bind_plain_key $top Control-u [format {
- if {!$Running} {
- if {[%s getSelection] != ""} {
- %s updateNow [%s getSelection]
- }
- }
- } $this $this $this]
-
- return [namespace tail $this].mmenu.var
- }
-
- # Return the current selection, or the empty string if none.
- method getSelection {} {
- return [$Hlist info selection]
- }
-
- # This is called when a selection is made. It updates the main
- # menu.
- method selectionChanged {variable} {
- global Display
-
- if {$Running} {
- # Clear the selection, too
- $Hlist selection clear
- return
- }
-
- # if something is being edited, cancel it
- if {[info exists EditEntry]} {
- UnEdit
- }
-
- if {$variable == ""} {
- set state disabled
- } else {
- set state normal
- }
-
- foreach menu [list [namespace tail $this].mmenu.var [namespace tail $this].mmenu.var.format ] {
- set i [$menu index last]
- while {$i >= 0} {
- if {[$menu type $i] != "cascade"} {
- $menu entryconfigure $i -state $state
- }
- incr i -1
- }
- }
-
- if {$variable != "" && [$variable editable]} {
- set state normal
- } else {
- set state disabled
- }
-
- if {$variable != ""} {
- set Display($this) [$variable format]
- }
-
- foreach label {Hex Decimal Binary Octal Natural} {
- [namespace tail $this].mmenu.var.format entryconfigure $label
- if {$label != "Hex"} {
- [namespace tail $this].mmenu.var.format entryconfigure $label -state $state
- }
- }
- # [namespace tail $this].mmenu.update entryconfigure 0 -variable Update($this,$name)
- }
-
- method updateNow {variable} {
- # debug "$variable"
-
- if {!$Running} {
- set text [label $variable]
- $Hlist entryconfigure $variable -itemtype text -text $text
- }
- }
-
- method getEntry {x y} {
- set realY [expr {$y - [winfo rooty $Hlist]}]
-
- # Get the tree entry which we are over
- return [$Hlist nearest $realY]
- }
-
- method editEntry {variable} {
- if {!$Running} {
- if {$variable != "" && [$variable editable]} {
- edit $variable
- }
- }
- }
-
- method postMenu {X Y} {
- global Update Display
- # debug
-
- # Quicky for menu posting problems.. How to unpost and post??
-
- if {[winfo ismapped $Popup] || $Running} {
- return
- }
-
- set variable [getEntry $X $Y]
- if {[string length $variable] > 0} {
- # First things first: highlight the variable we just selected
- $Hlist selection set $variable
-
- # Configure menu items
- # the title is always first..
- #set labelIndex [$Popup index "dummy"]
- set viewIndex [$Popup index "Format"]
- # set autoIndex [$Popup index "Auto Update"]
- # set updateIndex [$Popup index "Update Now"]
- set noEdit [catch {$Popup index "Edit"} editIndex]
-
- # Retitle and set update commands
- $Popup entryconfigure 0 -label "[$variable name]"
- # $Popup entryconfigure $autoIndex -command "$this toggleUpdate \{$entry\}" \
- -variable Update($this,$entry)
- # $Popup entryconfigure $updateIndex -command "$this updateNow \{$entry\}"
-
- # Edit pane
- if {$variable != "" && [$variable editable]} {
- if {!$noEdit} {
- $Popup delete $editIndex
- }
- if {![pref get gdb/mode]} {
- $Popup add command -label Edit -command "$this edit \{$variable\}"
- }
- } else {
- if {!$noEdit} {
- $Popup delete $editIndex
- }
- }
-
- # Set view menu
- set Display($this) [$variable format]
- foreach i {0 1 2 3 4} fmt {hexadecimal decimal binary octal natural} {
- debug "configuring entry $i ([$ViewMenu entrycget $i -label]) to $fmt"
- $ViewMenu entryconfigure $i \
- -command "$this setDisplay \{$variable\} $fmt"
- }
-
- if {$::tcl_platform(platform) == "windows"} {
- # Don't ask me why this works, but it does work around
- # a Win98/2000 Tcl bug with deleting entries from popups...
- set no [$Popup index end]
- for { set k 1 } { $k < $no } { incr k } {
- $Popup insert 1 command
- }
- $Popup delete 1 [expr {$no - 1}]
- }
-
- tk_popup $Popup $X $Y
- }
- }
-
- # ------------------------------------------------------------------
- # METHOD edit -- edit a variable
- # ------------------------------------------------------------------
- method edit {variable} {
- global Update
-
- # disable menus
- selectionChanged ""
- debug "editing \"$variable\""
-
- set fg [$Hlist cget -foreground]
- set bg [$Hlist cget -background]
-
- if {$Editing == ""} {
- # Must create the frame
- set Editing [frame $Hlist.frame -bg $bg -bd 0 -relief flat]
- set lbl [::label $Editing.lbl -fg $fg -bg $bg -font global/fixed]
- set ent [entry $Editing.ent -bg $::Colors(bg) -fg $::Colors(fg) -font global/fixed]
- pack $lbl $ent -side left
- }
-
- if {[info exists EditEntry]} {
- # We already are editing something... So reinstall it first
- # I guess we discard any changes?
- UnEdit
- }
-
- # Update the label/entry widgets for this instance
- set Update($this,$variable) 1
- set EditEntry $variable
- set label [label $variable 1]; # do not append value
- $Editing.lbl configure -text "$label "
- $Editing.ent delete 0 end
-
- # Strip the pointer type, text, etc, from pointers, and such
- set err [catch {$variable value} text]
- if {$err} {return}
- if {[$variable format] == "natural"} {
- # Natural formats must be stripped. They often contain
- # things like strings and characters after them.
- set index [string first \ $text]
- if {$index != -1} {
- set text [string range $text 0 [expr {$index - 1}]]
- }
- }
- $Editing.ent insert 0 $text
-
- # Find out what the previous entry is
- set previous [getPrevious $variable]
-
- $Hlist delete entry $variable
-
- set cmd [format { \
- %s add {%s} %s -itemtype window -window %s \
- } $Hlist $variable $previous $Editing]
- eval $cmd
-
- if {[$variable numChildren] > 0} {
- $Tree setmode $variable open
- }
-
- # Set focus to entry
- focus $Editing.ent
- $Editing.ent selection to end
-
- # Setup key bindings
- bind $Editing.ent <Return> "$this changeValue"
- bind $Hlist <Return> "$this changeValue"
- bind $Editing.ent <Escape> "$this UnEdit"
- bind $Hlist <Escape> "$this UnEdit"
- }
-
- method getPrevious {variable} {
- set prev [$Hlist info prev $variable]
- set parent [$Hlist info parent $variable]
-
- if {$prev != ""} {
- # A problem occurs with PREV if its parent is not the same as the entry's
- # parent. For example, consider these variables in the window:
- # + foo struct {...}
- # - bar struct {...}
- # a 1
- # b 2
- # local 0
- # if you attempt to edit "local", previous will be set at "bar.b", not
- # "struct bar"...
- if {[$Hlist info parent $prev] != $parent} {
- # This is the problem!
- # Find this object's sibling in that parent and place it there.
- set children [$Hlist info children $parent]
- set p {}
- foreach child $children {
- if {$child == $variable} {
- break
- }
- set p $child
- }
-
- if {$p == {}} {
- # This is the topmost child
- set previous "-before [lindex $children 1]"
- } else {
- set previous "-after $p"
- }
- } else {
- set previous "-after \{$prev\}"
- }
- } else {
- # this is the first!
- set previous "-at 0"
- }
-
- if {$prev == "$parent"} {
- # This is the topmost-member of a sub-grouping..
- set previous "-at 0"
- }
-
- return $previous
- }
-
- method UnEdit {} {
- set previous [getPrevious $EditEntry]
-
- $Hlist delete entry $EditEntry
- set cmd [format {\
- %s add {%s} %s -itemtype text -text {%s} \
- } $Hlist $EditEntry $previous [label $EditEntry]]
- eval $cmd
- if {[$EditEntry numChildren] > 0} {
- $Tree setmode $EditEntry open
- }
-
- # Unbind
- bind $Hlist <Return> {}
- bind $Hlist <Escape> {}
- if {$Editing != ""} {
- bind $Editing.ent <Return> {}
- bind $Editing.ent <Escape> {}
- }
-
- unset EditEntry
- selectionChanged ""
- }
-
- method changeValue {} {
- # Get the old value
- set new [string trim [$Editing.ent get] \ \r\n]
- if {$new == ""} {
- UnEdit
- return
- }
-
- if {[catch {$EditEntry value $new} errTxt]} {
- tk_messageBox -icon error -type ok -message $errTxt \
- -title "Error in Expression" -parent [winfo toplevel $itk_interior]
- focus $Editing.ent
- $Editing.ent selection to end
- } else {
- UnEdit
-
- # We may have changed a register or something else that is
- # being displayed in another window
- gdbtk_update
-
- # Get rid of entry... and replace it with new value
- focus $Tree
- }
- }
-
-
- # ------------------------------------------------------------------
- # METHOD: toggleView: Toggle open/close the current selection.
- # ------------------------------------------------------------------
- method toggleView {} {
-
- set v [getSelection]
- set mode [$Tree getmode $v]
-
- # In the tixTree widget, "open" means "openable", not that it is open...
-
- debug "mode=$mode"
- switch $mode {
- open {
- $Tree setmode $v close
- open $v
- }
-
- close {
- $Tree setmode $v open
- close $v
- }
-
- default {
- dbug E "What happened?"
- }
- }
- }
-
- method toggleUpdate {variable} {
- global Update
- debug $variable
- if {$Update($this,$variable)} {
- debug NORMAL
- # Must update value
- $Hlist entryconfigure $variable \
- -style $NormalTextStyle \
- -text [label $variable]
- } else {
- debug DISABLED
- $Hlist entryconfigure $variable \
- -style $DisabledTextStyle
- }
- ::update
- }
-
- method setDisplay {variable format} {
- debug "$variable $format"
- if {!$Running} {
- $variable format $format
- set ::Display($this) $format
- $Hlist entryconfigure $variable -text [label $variable]
- }
- }
-
- # ------------------------------------------------------------------
- # METHOD: label - used to label the entries in the tree
- # ------------------------------------------------------------------
- method label {variable {noValue 0}} {
- # Ok, this is as hack as it gets
- set blank " "
- # Use protected data Length to determine how big variable
- # name should be. This should clean the display up a little
- set name [$variable name]
- set indent [llength [split $variable .]]
- set indent [expr {$indent * $Length}]
- set len [string length $name]
- set l [expr {$EntryLength - $len - $indent}]
- set label "$name[string range $blank 0 $l]"
- #debug "label=$label $noValue"
- if {$noValue} {
- return $label
- }
-
- set err [catch {$variable value} value]
- set value [string trim $value \ \r\t\n]
- #debug "err=$err value=$value"
-
- # Insert the variable's type for things like ptrs, etc.
- set type [$variable type]
- if {!$err} {
- if {$value == "{...}"} {
- set val " $type $value"
- } elseif {[string first * $type] != -1} {
- set val " ($type) $value"
- } elseif {[string first \[ $type] != -1} {
- set val " $type"
- } else {
- set val " $value"
- }
- } else {
- set val " $value"
- }
-
- return "$label $val"
- }
-
- # ------------------------------------------------------------------
- # METHOD: open - used to open an entry in the variable tree
- # ------------------------------------------------------------------
- method open {path} {
- global Update
- # We must lookup all the variables for this struct
- # debug "$path"
-
- # Cancel any edits
- if {[info exists EditEntry]} {
- UnEdit
- }
-
- if {!$Running} {
- # Do not open disabled paths
- if {$Update($this,$path)} {
- cursor watch
- populate $path
- cursor {}
- }
- } else {
- $Tree setmode $path open
- }
- }
-
- # ------------------------------------------------------------------
- # METHOD: close - used to close an entry in the variable tree
- # ------------------------------------------------------------------
- method close {path} {
- global Update
- debug "$path"
- # Close the path and destroy all the entry widgets
-
- # Cancel any edits
- if {[info exists EditEntry]} {
- UnEdit
- }
-
- if {!$Running} {
- # Only update when we we are not disabled
- if {$Update($this,$path)} {
-
- # Delete the offspring of this entry
- $Hlist delete offspring $path
- }
- } else {
- $Tree setmode $path close
- }
- }
-
- method isVariable {var} {
-
- set err [catch {gdb_cmd "output $var"} msg]
- if {$err
- || [regexp -nocase "no symbol|syntax error" $msg]} {
- return 0
- }
-
- return 1
- }
-
- # OVERRIDE THIS METHOD
- method getVariablesBlankPath {} {
- dbug -W "You forgot to override getVariablesBlankPath!!"
- return {}
- }
-
- method cmd {cmd} {
- eval $cmd
- }
-
- # ------------------------------------------------------------------
- # METHOD: populate - populate an entry in the tree
- # ------------------------------------------------------------------
- method populate {parent} {
- global Update
- debug "$parent"
-
- if {[string length $parent] == 0} {
- set variables [getVariablesBlankPath]
- } else {
- set variables [$parent children]
- }
-
- debug "variables=$variables"
- eval $_queue push $variables
- for {set variable [$_queue pop]} {$variable != ""} {set variable [$_queue pop]} {
- debug "inserting variable: $variable"
- set Update($this,$variable) 1
-
- $Hlist add $variable \
- -itemtype text \
- -text [label $variable]
- if {[$variable numChildren] > 0} {
- # Make sure we get this labeled as openable
- $Tree setmode $variable open
- }
-
- # Special case: If we see "public" with no value or type, then we
- # have one of our special c++/java children. Open it automagically
- # for the user.
- if {[string compare [$variable name] "public"] == 0
- && [$variable type] == "" && [$variable value] == ""} {
- eval $_queue push [$variable children]
- $Tree setmode $variable close
- }
- }
-
- debug "done with populate"
- }
-
- # Get all current locals
- proc getLocals {} {
-
- set vars {}
- set err [catch {gdb_get_args} v]
- if {!$err} {
- set vars [concat $vars $v]
- }
-
- set err [catch {gdb_get_locals} v]
- if {!$err} {
- set vars [concat $vars $v]
- }
-
- debug "--getLocals:\n$vars\n--getLocals"
- return [lsort $vars]
- }
-
- method context_switch {} {
- set err [catch {gdb_selected_frame} current_frame]
- debug "1: err=$err; _frame=\"$_frame\"; current_frame=\"$current_frame\""
- if {$err && $_frame != ""} {
- # No current frame
- debug "no current frame"
- catch {destroy $_frame}
- set _frame {}
- return 1
- } elseif {$current_frame == "" && $_frame == ""} {
- debug "2"
- return 0
- } elseif {$_frame == "" || $current_frame != [$_frame address]} {
- # We've changed frames. If we knew something about
- # the stack layout, we could be more intelligent about
- # destroying variables, but we don't know that here (yet).
- debug "switching to frame at $current_frame"
-
- # Destroy the old frame and create the new one
- catch {destroy $_frame}
- set _frame [Frame ::\#auto $current_frame]
- debug "created new frame: $_frame at [$_frame address]"
- return 1
- }
-
- # Nothing changed
- debug "3"
- return 0
- }
-
- # ------------------------------------------------------------------
- # METHOD: update
- # OVERRIDE THIS METHOD and call it from there
- # ------------------------------------------------------------------
- method update {event} {
- global Update
- debug
-
- # First, reset color on label to normal
- foreach w $ChangeList {
- catch {
- $Hlist entryconfigure $w -style $NormalTextStyle
- }
- }
-
- # Tell toplevel variables to update themselves. This will
- # give us a list of all the variables in the table that
- # have changed values.
- set ChangeList {}
- set variables [$Hlist info children {}]
- foreach var $variables {
- # debug "VARIABLE: $var ($Update($this,$var))"
- set numchild [$var numChildren]
- set UpdatedList [$var update]
- # FIXME: For now, we can only infer that the type has changed
- # if the variable is not a scalar; the varobj code will have to
- # give us an indication that this happened.
- if {([lindex $UpdatedList 0] == $var)
- && ($numchild > 0)} {
- debug "Type changed."
- # We must fix the tree entry to correspond to the new type
- $Hlist delete offsprings $var
- $Hlist entryconfigure $var -text [label $var]
- if {[$var numChildren] > 0} {
- $Tree setmode $var open
- } else {
- $Tree setmode $var none
- }
- } else {
- set ChangeList [concat $ChangeList $UpdatedList]
- # debug "ChangeList=$ChangeList"
- }
- }
-
- foreach var $ChangeList {
- debug "$var HIGHLIGHT"
- $Hlist entryconfigure $var \
- -style $HighlightTextStyle \
- -text [label $var]
- }
- }
-
- method idle {event} {
- # Re-enable the UI
- enable_ui
- }
-
- # RECURSION!!
- method displayedVariables {top} {
- # debug
- set variableList {}
- set variables [$Hlist info children $top]
- foreach var $variables {
- set mode [$Tree getmode $var]
- if {$mode == "close"} {
- set moreVars [displayedVariables $var]
- lappend variableList [join $moreVars]
- }
- lappend variableList $var
- }
-
- return [join $variableList]
- }
-
- method deleteTree {} {
- global Update
- debug
-# set variables [displayedVariables {}]
-
- # Delete all HList entries
- $Hlist delete all
-
- # Delete the variable objects
-# foreach i [array names Variables] {
-# $Variables($i) delete
-# unset Variables($i)
-# catch {unset Update($this,$i)}
-# }
- }
-
- # ------------------------------------------------------------------
- # METHOD: enable_ui
- # Enable all ui elements.
- # ------------------------------------------------------------------
- method enable_ui {} {
-
- # Clear fencepost
- set Running 0
- cursor {}
- }
-
- # ------------------------------------------------------------------
- # PUBLIC METHOD: busy - BusyEvent handler
- # Disable all ui elements that could affect gdb's state
- # ------------------------------------------------------------------
- method busy {event} {
-
- # Set fencepost
- set Running 1
-
- # Cancel any edits
- if {[info exists EditEntry]} {
- UnEdit
- }
-
- # Change cursor
- cursor watch
- }
-
- # ------------------------------------------------------------------
- # METHOD: no_inferior
- # Reset this object.
- # ------------------------------------------------------------------
- method no_inferior {} {
-
- # Clear out the Hlist
- deleteTree
-
- # Clear fencepost
- set Running 0
- set _frame {}
- cursor {}
- }
-
- # ------------------------------------------------------------------
- # METHOD: cursor - change the toplevel's cursor
- # ------------------------------------------------------------------
- method cursor {what} {
- [winfo toplevel [namespace tail $this]] configure -cursor $what
- ::update idletasks
- }
-
- #
- # PUBLIC DATA
- #
-
- #
- # PROTECTED DATA
- #
-
- # the tixTree widget for this class
- protected variable Tree {}
-
- # the hlist of this widget
- protected variable Hlist {}
-
- # entry widgets which need to have their color changed back to black
- # when idle (used in conjunction with update)
- protected variable ChangeList {}
-
- protected variable ViewMenu
- protected variable Popup
-
- # These are for setting the indent level to an number of characters.
- # This will help clean the tree a little
- common EntryLength 15
- common Length 1
- common LengthString " "
-
- # These should be common... but deletion?
- # Display styles for HList
- protected variable HighlightTextStyle
- protected variable NormalTextStyle
- protected variable DisabledTextStyle
-
- protected variable Radix
-
- # Frame object for the selected frame
- protected variable _frame {}
-
- protected variable Editing {}
- protected variable EditEntry
-
- # Fencepost for enable/disable_ui and idle/busy hooks.
- protected variable Running 0
-
- # little queue for convenience
- protected variable _queue {}
-}
--- /dev/null
+# 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]
+ set j3 [$c create text $x $y -text "[$var value]" -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 {[$c itemcget $val -text] != [$var value]} {
+ $c itemconfigure $val -text [$var value] -fill $colors(change)
+ } else {
+ $c itemconfigure $val -text [$var value] -fill $colors(value)
+ }
+ } 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]
+ $pop add separator
+ if {$type == "local"} {
+ $pop add command -label "Help" -command "HtmlViewer::open_help watch.html"
+ } else {
+ $pop add command -label "Help" -command "HtmlViewer::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 "HtmlViewer::open_help watch.html"
+ } else {
+ $pop add command -label "Help" -command "HtmlViewer::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(value) "black"
+ set colors(change) "green"
+ 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
+}
+
--- /dev/null
+# Variable tree class definition 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::class VarTree {
+ inherit itk::Widget
+
+ public variable type "watch"
+
+ private {
+ # list of root variables in tree
+ variable rootlist {}
+
+ # mapping of varobj to canvas items
+ variable var_to_items
+ variable item_to_var
+
+ variable c ;#the canvas
+ variable pop ;#popup menu
+ variable _y 0
+ variable selection
+ variable selidx
+ variable closed
+
+ variable popup_temp
+
+ # when editing, these contain the entry widget and edited varobj
+ variable entry ""
+ variable entryobj
+ variable entrywin
+ }
+
+ common maskdata
+ common data
+ common openbm
+ common closedbm
+ common initialized 0
+ common colors
+
+ private {
+ method _init_data {}
+ method build {}
+ method buildlayer {tlist n}
+ method drawselection {}
+ method clicked {w x y open}
+ method setselection {var}
+ method closed {name}
+ method open {name}
+ method close {name}
+ method edit {j}
+ method unedit {j}
+ method changeValue {j}
+ method update_var {var ena check}
+ method _but3 {x y X Y}
+ method _change_format {var}
+ method _do_default_menu {X Y}
+ method _sort {}
+ method _compare {a b}
+ }
+
+ public {
+ method constructor {args}
+ method destructor {}
+ method add {varobj}
+ method remove {varobj}
+ method update {{check 0}}
+ }
+}
\ No newline at end of file
# Watch window for Insight.
-# Copyright 1997, 1998, 1999, 2001, 2002 Red Hat
+# Copyright 2002 Red Hat
#
# 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
# ----------------------------------------------------------------------
-# Implements watch windows for gdb. Inherits the VariableWin
-# class from variables.tcl.
+# Implements watch windows for gdb.
# ----------------------------------------------------------------------
itcl::class WatchWin {
- inherit VariableWin
-
+ inherit EmbeddedWin GDBWin
# ------------------------------------------------------------------
- # CONSTRUCTOR - create new locals window
+ # CONSTRUCTOR - create new watch window
# ------------------------------------------------------------------
constructor {args} {
- set Sizebox 0
+ debug
- # Only allow one watch window for now...
- if {$init} {
- set init 0
- }
+ gdbtk_busy
+ build_win $itk_interior
+ gdbtk_idle
+
+ add_hook gdb_no_inferior_hook "$this no_inferior"
+ add_hook gdb_clear_file_hook [code $this clear_file]
+ add_hook file_changed_hook [code $this clear_file]
}
+
# ------------------------------------------------------------------
- # METHOD: build_win - build window for watch. This supplants the
- # one in VariableWin, so that we can add the entry at the
- # bottom.
+ # PUBLIC METHOD: busy - BusyEvent handler
+ # Disable all ui elements that could affect gdb's state
# ------------------------------------------------------------------
- method build_win {f} {
- global tcl_platform
- #debug "$f"
+ method busy {event} {
+ debug
+ set Running 1
+ cursor watch
+ }
- set Menu [build_menu_helper Watch]
- $Menu add command -label Remove -underline 0 \
- -command [format {
- %s remove [%s getSelection]
- } $this $this]
+ # Re-enable the UI
+ method idle {event} {
+ debug
+ set Running 0
+ cursor {}
+ }
+ # ------------------------------------------------------------------
+ # METHOD: no_inferior
+ # Reset this object.
+ # ------------------------------------------------------------------
+ method no_inferior {} {
+ debug
+ cursor {}
+ set Running 0
+ }
+
+ # ------------------------------------------------------------------
+ # METHOD: cursor - change the toplevel's cursor
+ # ------------------------------------------------------------------
+ method cursor {what} {
+ [winfo toplevel [namespace tail $this]] configure -cursor $what
+ ::update idletasks
+ }
+
+
+ # ------------------------------------------------------------------
+ # METHOD: build_win - build window for watch.
+ # ------------------------------------------------------------------
+ method build_win {f} {
+ #debug "$f"
+
set f [::frame $f.f]
set treeFrame [frame $f.top]
set entryFrame [frame $f.expr]
- VariableWin::build_win $treeFrame
+
+ set tree [VarTree $treeFrame.tree]
+ pack $tree -expand yes -fill both
+
set Entry [entry $entryFrame.ent -font global/fixed]
button $entryFrame.but -text "Add Watch" -command [code $this validateEntry]
pack $f -fill both -expand yes
grid columnconfigure $entryFrame 0 -weight 1
grid columnconfigure $entryFrame 1
- if {$tcl_platform(platform) == "windows"} {
+ if {$::tcl_platform(platform) == "windows"} {
grid columnconfigure $entryFrame 1 -pad 20
ide_sizebox [namespace tail $this].sizebox
place [namespace tail $this].sizebox -relx 1 -rely 1 -anchor se
grid $entryFrame -row 1 -column 0 -padx 5 -pady 5 -sticky news
grid columnconfigure $f 0 -weight 1
grid rowconfigure $f 0 -weight 1
- window_name "Watch Expressions"
+ window_name "Watch"
::update idletasks
# Binding for the entry
bind $entryFrame.ent <Return> "$entryFrame.but flash; $entryFrame.but invoke"
-
- }
-
- method selectionChanged {entry} {
- VariableWin::selectionChanged $entry
-
- set state disabled
- set entry [getSelection]
- foreach var $Watched {
- set name [lindex $var 0]
- if {"$name" == "$entry"} {
- set state normal
- break
- }
- }
-
- $Menu entryconfigure last -state $state
}
method validateEntry {} {
set variable [$Entry get]
debug "Got $variable, going to add"
set ok [add $variable]
- debug "Added... with ok: $ok"
-
+ debug "Added... with ok: $ok"
$Entry delete 0 end
}
}
# ------------------------------------------------------------------
# METHOD: clear_file - Clear out state so that a new executable
# can be loaded. For WatchWins, this means deleting
- # the Watched list, in addition to the normal
- # VariableWin stuff.
+ # the Watched list.
# ------------------------------------------------------------------
method clear_file {} {
- VariableWin::clear_file
+ debug
set Watched {}
}
# DESTRUCTOR - delete watch window
# ------------------------------------------------------------------
destructor {
- foreach var $Watched {
- $var delete
- }
- }
+ debug
+ set tree {}
- method postMenu {X Y} {
-# debug "$x $y"
+ # Remove this window and all hooks
+ remove_hook gdb_no_inferior_hook "$this no_inferior"
+ remove_hook gdb_clear_file_hook [code $this clear_file]
+ remove_hook file_changed_hook [code $this clear_file]
- set entry [getEntry $X $Y]
-
- # Disable "Remove" if we are not applying this to the parent
- set found 0
foreach var $Watched {
- set name [lindex $var 0]
- if {"$name" == "$entry"} {
- set found 1
- break
- }
- }
-
- # Ok, nasty, but a sad reality...
- set noStop [catch {$Popup index "Remove"} i]
- if {!$noStop} {
- $Popup delete $i
- }
- if {$found} {
- $Popup add command -label "Remove" -command "$this remove \{$entry\}"
+ $var delete
}
-
- VariableWin::postMenu $X $Y
}
method remove {entry} {
- global Display Update
+ debug $entry
# Remove this entry from the list of watched variables
- set i [lsearch -exact $Watched $entry]
- if {$i == -1} {
- debug "WHAT HAPPENED?"
- return
- }
- set Watched [lreplace $Watched $i $i]
-
- set list [$Hlist info children $entry]
- lappend list $entry
- $Hlist delete entry $entry
+ set Watched [lremove $Watched $entry]
+ $entry remove
$entry delete
}
- # ------------------------------------------------------------------
- # METHOD: getVariablesBlankPath
- # Overrides VarialbeWin::getVariablesBlankPath. For a Watch Window,
- # this method returns a list of watched variables.
- #
- # ONLY return items that need to be added to the Watch Tree
- # (or use deleteTree)
- # ------------------------------------------------------------------
- method getVariablesBlankPath {} {
-# debug
- set list {}
-
- set variables [displayedVariables {}]
- foreach var $variables {
- set name [$var name]
- set on($name) 1
- }
-
- foreach var $Watched {
- set name [$var name]
- if {![info exists on($name)]} {
- lappend list $var
- }
- }
-
- return $list
- }
method update {event} {
- global Update Display
- debug "START WATCH UPDATE CALLBACK"
- catch {populate {}} msg
- catch {VariableWin::update dummy} msg
- debug "Did VariableWin::update with return \"$msg\""
-
- # Make sure all variables are marked as _not_ Openable?
- debug "END WATCH UPDATE CALLBACK"
+ $tree update
}
- method showMe {} {
- debug "Watched: $Watched"
- }
# ------------------------------------------------------------------
# METHOD: add - add a variable to the watch window
# ------------------------------------------------------------------
method add {name} {
- debug "Trying to add \"$name\" to watch"
+ debug "Trying to add \"$name\" to watch"
# Strip all the junk after the first \n
set var [split $name \n]
debug "In add, going to add $name"
# make one last attempt to get errors
set err [catch {set foo($name) 1}]
+ debug "err1=$err"
set err [expr {$err + [catch {expr {$foo($name) + 1}}]}]
+ debug "err2=$err"
if {!$err} {
- set var [gdb_variable create -expr $name]
- set ::Update($this,$var) 1
- lappend Watched $var
- update dummy
- return 1
+ set var [gdb_variable create -expr $name]
+ debug "var=$var"
+ $tree add $var
+ lappend Watched $var
+ return 1
}
- }
-
+ }
return 0
}
protected variable Entry
protected variable Watched {}
- protected variable Menu {}
- protected common init 1
+ protected variable tree
+ protected variable Running
}
OSDN Git Service
