diff options
author | Martin Hunt <hunt@redhat.com> | 2002-11-06 21:05:24 +0000 |
---|---|---|
committer | Martin Hunt <hunt@redhat.com> | 2002-11-06 21:05:24 +0000 |
commit | b8befbd9322af9020752ccdd965dbee4d2969f30 (patch) | |
tree | 93e6a202a9aa056e64e87e4fbc48c43e541c401d /gdb/gdbtk | |
parent | ad23afcb2b8465db98ae495763421ec136b34605 (diff) | |
download | gdb-b8befbd9322af9020752ccdd965dbee4d2969f30.tar.gz |
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.
Diffstat (limited to 'gdb/gdbtk')
-rw-r--r-- | gdb/gdbtk/ChangeLog | 9 | ||||
-rw-r--r-- | gdb/gdbtk/library/locals.tcl | 275 | ||||
-rw-r--r-- | gdb/gdbtk/library/tclIndex | 28 | ||||
-rw-r--r-- | gdb/gdbtk/library/variables.tcl | 1001 | ||||
-rw-r--r-- | gdb/gdbtk/library/vartree.itb | 417 | ||||
-rw-r--r-- | gdb/gdbtk/library/vartree.ith | 77 | ||||
-rw-r--r-- | gdb/gdbtk/library/watch.tcl | 214 |
7 files changed, 783 insertions, 1238 deletions
diff --git a/gdb/gdbtk/ChangeLog b/gdb/gdbtk/ChangeLog index d64cd89cd6f..76c2dabc515 100644 --- a/gdb/gdbtk/ChangeLog +++ b/gdb/gdbtk/ChangeLog @@ -1,5 +1,14 @@ 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. diff --git a/gdb/gdbtk/library/locals.tcl b/gdb/gdbtk/library/locals.tcl index 1af84abc5f2..118c5285eaa 100644 --- a/gdb/gdbtk/library/locals.tcl +++ b/gdb/gdbtk/library/locals.tcl @@ -1,5 +1,5 @@ -# 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 @@ -12,112 +12,177 @@ # 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 {} } - diff --git a/gdb/gdbtk/library/tclIndex b/gdb/gdbtk/library/tclIndex index 3a2c77630ec..dcf2e280987 100644 --- a/gdb/gdbtk/library/tclIndex +++ b/gdb/gdbtk/library/tclIndex @@ -91,6 +91,10 @@ set auto_index(escape_value) [list source [file join $dir prefs.tcl]] 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]] @@ -171,6 +175,7 @@ set auto_index(SrcWin) [list source [file join $dir srcwin.ith]] 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]] @@ -611,3 +616,26 @@ set auto_index(::TargetSelection::set_run) [list source [file join $dir targetse 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]] diff --git a/gdb/gdbtk/library/variables.tcl b/gdb/gdbtk/library/variables.tcl deleted file mode 100644 index 2faeb2f686f..00000000000 --- a/gdb/gdbtk/library/variables.tcl +++ /dev/null @@ -1,1001 +0,0 @@ -# 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 {} -} diff --git a/gdb/gdbtk/library/vartree.itb b/gdb/gdbtk/library/vartree.itb new file mode 100644 index 00000000000..a3c46e0c786 --- /dev/null +++ b/gdb/gdbtk/library/vartree.itb @@ -0,0 +1,417 @@ +# 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 +} + diff --git a/gdb/gdbtk/library/vartree.ith b/gdb/gdbtk/library/vartree.ith new file mode 100644 index 00000000000..b250f2ea2cb --- /dev/null +++ b/gdb/gdbtk/library/vartree.ith @@ -0,0 +1,77 @@ +# 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 diff --git a/gdb/gdbtk/library/watch.tcl b/gdb/gdbtk/library/watch.tcl index 94d41bc496c..d2fc3223b25 100644 --- a/gdb/gdbtk/library/watch.tcl +++ b/gdb/gdbtk/library/watch.tcl @@ -1,5 +1,5 @@ # 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 @@ -13,44 +13,76 @@ # ---------------------------------------------------------------------- -# 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 @@ -59,7 +91,7 @@ itcl::class WatchWin { 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 @@ -69,27 +101,10 @@ itcl::class WatchWin { 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 {} { @@ -98,8 +113,7 @@ itcl::class WatchWin { 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 } } @@ -107,11 +121,10 @@ itcl::class WatchWin { # ------------------------------------------------------------------ # 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 {} } @@ -119,104 +132,40 @@ itcl::class WatchWin { # 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] @@ -250,21 +199,22 @@ itcl::class WatchWin { 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 } |