You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1052 lines
31 KiB
Plaintext
1052 lines
31 KiB
Plaintext
# Register display window for Insight.
|
|
# Copyright (C) 1998, 1999, 2001, 2002, 2003, 2004, 2007 Red Hat, Inc.
|
|
#
|
|
# Written by Keith Seitz (keiths@redhat.com)
|
|
# and Martin Hunt (hunt@redhat.com)
|
|
#
|
|
# 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.
|
|
|
|
# TODO
|
|
#
|
|
# Must fix:
|
|
# o Edit menus -- weirdo interaction with tkTable. Seems okay on windows.
|
|
# Needs more testing on unix (popup edit menu item).
|
|
#
|
|
# Want really badly:
|
|
# o Multiple selections
|
|
# o Multiple displays
|
|
# o Better resizing
|
|
# o Register groups (gdb and user-defined)
|
|
# o format register values before inserting into table?
|
|
# (Instead of displaying "0x0", we should use "0x00000000" on
|
|
# machines with 32-bit regs, "0x0000000000000000" on machines
|
|
# with 64-bit regs, etc. Maybe user-defined formats, i.e.,
|
|
# "0x0000 0000 0000 0000 0000 0000"?)
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: RegWin::constructor
|
|
# DESCRIPTION: Create a new register window
|
|
#
|
|
# ARGUMENTS: None
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::constructor {args} {
|
|
|
|
eval itk_initialize $args
|
|
|
|
gdbtk_busy
|
|
|
|
window_name "Registers" "Regs"
|
|
_build_win
|
|
_layout_table
|
|
|
|
# Clear gdb's changed list
|
|
catch {gdb_reginfo changed}
|
|
|
|
gdbtk_idle
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: RegWin::destructor
|
|
# DESCRIPTION: Destroys the register window
|
|
#
|
|
# ARGUMENTS: None
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::destructor {} {
|
|
debug
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: RegWin::_load_prefs
|
|
# DESCRIPTION: Load register preferences
|
|
#
|
|
# ARGUMENTS: None
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_load_prefs {} {
|
|
debug
|
|
|
|
# Find out largest register name length.
|
|
set _max_label_width 0; # for reg labels
|
|
set _reg_display_list {}
|
|
set _register(hidden) {}
|
|
|
|
set regs [gdb_reginfo group $_group]
|
|
foreach r [gdb_reginfo name -numbers $regs] {
|
|
set nm [lindex $r 0]
|
|
set rn [lindex $r 1]
|
|
set size [string length $nm]
|
|
if {$size > $_max_label_width} {
|
|
set _max_label_width $size
|
|
}
|
|
|
|
# Set type from prefs or default to first in list of types
|
|
set _types($rn) [gdb_reginfo type $rn]
|
|
set tp [pref getd gdb/reg/${nm}-type]
|
|
set _type($rn,name) ""
|
|
if {$tp != ""} {
|
|
foreach t $_types($rn) {
|
|
if {[lindex $t 0] == $tp} {
|
|
set _type($rn,name) $tp
|
|
set _type($rn,addr) [lindex $t 1]
|
|
set _type($rn,code) [lindex $t 2]
|
|
break
|
|
}
|
|
}
|
|
}
|
|
if {$_type($rn,name) == ""} {
|
|
# either not set or couldn't find it in list of types
|
|
set _type($rn,name) [lindex [lindex $_types($rn) 0] 0]
|
|
set _type($rn,addr) [lindex [lindex $_types($rn) 0] 1]
|
|
set _type($rn,code) [lindex [lindex $_types($rn) 0] 2]
|
|
}
|
|
|
|
# Check preferences for format
|
|
set _format($rn) [pref getd gdb/reg/${nm}-format]
|
|
if {$_format($rn) == ""} {
|
|
# no preference set. Set it to hex or float
|
|
if {$_type($rn,code) == "int"} {
|
|
set _format($rn) "x"
|
|
} else {
|
|
set _format($rn) "f"
|
|
}
|
|
pref setd gdb/reg/${nm}-format $_format($rn)
|
|
}
|
|
|
|
gdb_reginfo format $rn $_type($rn,addr) $_format($rn)
|
|
|
|
# Check if the user prefers not to show this register
|
|
if {[pref getd gdb/reg/$nm] == "no"} {
|
|
set _cell($rn) hidden
|
|
lappend _register(hidden) $rn
|
|
} else {
|
|
lappend _reg_display_list $rn
|
|
}
|
|
|
|
# assume editable, for now
|
|
set _editable($rn) 1
|
|
}
|
|
|
|
incr _max_label_width 2; # padding
|
|
}
|
|
|
|
|
|
#
|
|
# Table layout/display methods
|
|
#
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_build_win
|
|
# DESCRIPTION: Builds the register window from widgets
|
|
#
|
|
# ARGUMENTS: None
|
|
# RETURNS: Nothing
|
|
#
|
|
# NOTES: This method should only be called once for
|
|
# each RegWin. To change the layout of the table
|
|
# in the window, use RegWin::_layout_table.
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_build_win {} {
|
|
|
|
# Create scrollbars and table
|
|
itk_component add vscroll {
|
|
scrollbar $itk_interior.vs -orient vertical
|
|
}
|
|
itk_component add hscroll {
|
|
scrollbar $itk_interior.hs -orient horizontal
|
|
}
|
|
|
|
itk_component add table {
|
|
::table $itk_interior.tbl -variable [scope _data] \
|
|
-browsecmd [code $this _select_cell %S] -font global/fixed \
|
|
-colstretch unset -rowstretch unset -selectmode single \
|
|
-resizeborders none -multiline false -colwidth 18 \
|
|
-autoclear 0 -bg $::Colors(bg) \
|
|
-padx 5 -xscrollcommand [code $itk_component(hscroll) set] \
|
|
-yscrollcommand [code $itk_component(vscroll) set]
|
|
} {
|
|
keep -foreground
|
|
keep -insertbackground
|
|
keep -highlightcolor
|
|
keep -highlightbackground
|
|
}
|
|
bind $itk_component(table) <Up> \
|
|
[format "%s; break" [code $this _move up]]
|
|
bind $itk_component(table) <Down> \
|
|
[format "%s; break" [code $this _move down]]
|
|
bind $itk_component(table) <Left> \
|
|
[format "%s; break" [code $this _move left]]
|
|
bind $itk_component(table) <Right> \
|
|
[format "%s; break" [code $this _move right]]
|
|
bind $itk_component(table) <3> \
|
|
[code $this _but3 %x %y %X %Y]
|
|
bind $itk_component(table) <Double-1> break
|
|
bind $itk_component(table) <1> \
|
|
[code $this _edit %x %y]
|
|
bind $itk_component(table) <Return> \
|
|
[format "%s; break" [code $this _accept_edit]]
|
|
bind $itk_component(table) <KP_Enter> \
|
|
[format "%s; break" [code $this _accept_edit]]
|
|
bind $itk_component(table) <Escape> \
|
|
[code $this _unedit]
|
|
|
|
$itk_component(hscroll) configure -command [code $itk_component(table) xview]
|
|
$itk_component(vscroll) configure -command [code $itk_component(table) yview]
|
|
|
|
|
|
# Create/configure tags for various display styles
|
|
# normal - the "normal" display style
|
|
# highlight - changed registers are highlighted
|
|
# sel - the selection fg/bg should conform to standard
|
|
# header - used on the register name cells and empty cells
|
|
# edit - used on a cell being edited
|
|
$itk_component(table) tag configure normal \
|
|
-state disabled -bg $::Colors(textbg) -fg $::Colors(textfg)
|
|
$itk_component(table) tag configure sel -bg $::Colors(sbg) -fg $::Colors(sfg)
|
|
$itk_component(table) tag configure highlight -bg $::Colors(change) -fg black
|
|
$itk_component(table) tag raise highlight
|
|
$itk_component(table) tag configure header \
|
|
-anchor w -state disabled -relief raised
|
|
$itk_component(table) tag configure disabled \
|
|
-state disabled
|
|
$itk_component(table) tag raise active
|
|
$itk_component(table) tag configure edit \
|
|
-state normal
|
|
$itk_component(table) tag raise edit
|
|
$itk_component(table) tag raise sel
|
|
|
|
itk_component add frame {
|
|
frame $itk_interior.m
|
|
}
|
|
iwidgets::optionmenu $itk_component(frame).opt -labeltext "Group:" \
|
|
-labelpos w -command [code $this _select_group]
|
|
eval $itk_component(frame).opt insert end [gdb_reginfo grouplist]
|
|
$itk_component(frame).opt select "all"
|
|
|
|
pack $itk_component(frame).opt -anchor nw
|
|
grid $itk_component(frame) -row 0 -columnspan 2 -sticky news
|
|
grid $itk_component(table) -row 1 -column 0 -sticky news
|
|
grid $itk_component(vscroll) -row 1 -column 1 -sticky ns
|
|
grid $itk_component(hscroll) -row 2 -column 0 -sticky ew
|
|
grid columnconfigure $itk_interior 0 -weight 1
|
|
grid rowconfigure $itk_interior 0 -weight 0
|
|
grid rowconfigure $itk_interior 1 -weight 1
|
|
|
|
# Add popup menu - we populate it in the event handler
|
|
itk_component add popup {
|
|
menu $itk_interior.pop -tearoff 0
|
|
} {}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_layout_table
|
|
# DESCRIPTION: Configures and lays out the table
|
|
#
|
|
# ARGUMENTS: None
|
|
# RETURNS: Nothing
|
|
#
|
|
# NOTES: Uses preferences to determine if/how a register
|
|
# is displayed
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_layout_table {} {
|
|
debug
|
|
|
|
if {[info exists _cell]} {
|
|
unset _cell
|
|
unset _register
|
|
}
|
|
# Clear any column spans
|
|
foreach span [$itk_component(table) spans] {
|
|
$itk_component(table) spans $span 0,0
|
|
}
|
|
|
|
_load_prefs
|
|
|
|
# Fill data array with register names.
|
|
#
|
|
# The table is indexed by (row,col). All odd columns will contain
|
|
# register values and all even columns will contain the labels.
|
|
#
|
|
set x 0
|
|
set y 0
|
|
|
|
# get register list
|
|
set regs [gdb_reginfo name -numbers $_reg_display_list]
|
|
|
|
# Set table dimensions
|
|
set num [llength $regs]
|
|
set _rows [pref get gdb/reg/rows]
|
|
set _cols [expr $num / $_rows]
|
|
if {[expr $num % $_rows] != 0} { incr _cols }
|
|
set _cols [expr 2 * $_cols]
|
|
$itk_component(table) configure -cols $_cols -rows $_rows
|
|
|
|
# get values
|
|
if {[catch {gdb_reginfo value $_reg_display_list} values]} {
|
|
dbug W "values=$values"
|
|
set values ""
|
|
}
|
|
set i 0
|
|
|
|
# now build table
|
|
foreach r $regs {
|
|
set name [lindex $r 0]
|
|
set rn [lindex $r 1]
|
|
|
|
set _cell($rn) "$y,[expr {$x+1}]"
|
|
set _register($_cell($rn)) $rn
|
|
set _data($y,$x) $name
|
|
set _data($_cell($rn)) [lindex $values $i]
|
|
incr i
|
|
|
|
# Go to next row/column
|
|
incr y
|
|
if {$y == $_rows} {
|
|
set _col_size([expr {$x+1}]) 0
|
|
|
|
# Size the column
|
|
if {$::gdb_running} {
|
|
_size_column [expr {$x+1}] 1
|
|
}
|
|
|
|
$itk_component(table) width $x $_max_label_width
|
|
$itk_component(table) tag col header $x
|
|
$itk_component(table) tag col normal [expr {$x+1}]
|
|
|
|
set y 0
|
|
incr x 2
|
|
}
|
|
}
|
|
|
|
# Mark empty cells
|
|
while {$y != $_rows && $x != $_cols} {
|
|
set _data($y,$x) ""
|
|
set _data($y,[expr {$x+1}]) ""
|
|
$itk_component(table) spans $y,$x 0,1
|
|
$itk_component(table) tag cell header $y,$x
|
|
set _col_size([expr {$x+1}]) 0
|
|
|
|
incr y
|
|
if {$y == $_rows} {
|
|
# Size the column
|
|
if {$::gdb_running} {
|
|
_size_column [expr {$x+1}] 1
|
|
}
|
|
$itk_component(table) width $x $_max_label_width
|
|
$itk_component(table) tag col header $x
|
|
$itk_component(table) tag col normal [expr {$x+1}]
|
|
|
|
set y 0
|
|
incr x 2
|
|
}
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_size_cell_column
|
|
# DESCRIPTION: Resize the column for a given cell.
|
|
#
|
|
# ARGUMENTS:
|
|
# cell - the cell whose column is to be resized
|
|
# down - whether the resizing should size the column
|
|
# down or just up.
|
|
# RETURNS: Nothing
|
|
#
|
|
# NOTES: See _size_column for the reasoning for the "down"
|
|
# option.
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_size_cell_column {cell down} {
|
|
|
|
set col [string trim [lindex [split $cell ,] 1] ()]
|
|
_size_column $col $down
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_size_column
|
|
# DESCRIPTION: Resize the given column
|
|
#
|
|
# ARGUMENTS:
|
|
# col - the column to be resized
|
|
# down - whether the resizing should size the column
|
|
# RETURNS: down or just up.
|
|
#
|
|
# NOTES: The down option allows column sizes to change down
|
|
# as well as up. For most cases, this is what is
|
|
# wanted. However, when the user is stepping, it is
|
|
# really annoying to see the column sizes changing.
|
|
# It's bad enough we must size up, but going down
|
|
# is just too much. Consequently, when updating the
|
|
# contents of the table, we specify that the columns
|
|
# should not downsize. This helps mitigate the
|
|
# annoyance.
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_size_column {col down} {
|
|
|
|
set max 0
|
|
foreach cell [array names _data *,$col] {
|
|
set len [string length $_data($cell)]
|
|
if {$len > $max} { set max $len }
|
|
}
|
|
|
|
if {($down && $max != $_col_size($col))
|
|
|| (!$down && $max > $_col_size($col))} {
|
|
set _col_size($col) $max
|
|
$itk_component(table) width $col [expr {$max + 2}]
|
|
|
|
# Force the table to update itself
|
|
after idle event generate $itk_component(table) <Configure> \
|
|
-width [winfo width $itk_component(table)]
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::reconfig
|
|
# DESCRIPTION: Reconfigures register window when a preference
|
|
# changes.
|
|
#
|
|
# ARGUMENTS: None
|
|
# RETURNS: Nothing
|
|
#
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::reconfig {} {
|
|
$itk_component(table) tag configure normal \
|
|
-state disabled -bg $::Colors(textbg) -fg $::Colors(textfg)
|
|
}
|
|
|
|
|
|
#
|
|
# Table event handlers and related methods
|
|
#
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_accept_edit
|
|
# DESCRIPTION: Change a register's value
|
|
#
|
|
# ARGUMENTS: None
|
|
# RETURNS: Nothing
|
|
#
|
|
# NOTES: Event handler for <Enter> and <KP_Enter>
|
|
# in table
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_accept_edit {} {
|
|
debug
|
|
set cell [$itk_component(table) tag cell edit]
|
|
if {[llength $cell] == 1 && [info exists _register($cell)]} {
|
|
# Select the same cell again. This forces the table
|
|
# to keep this value. Otherwise, we'll never see it...
|
|
_select_cell $cell
|
|
set rn $_register($cell)
|
|
set n [gdb_reginfo name $rn]
|
|
if {[llength $_types($rn)] > 1} {
|
|
append n ".$_type($rn,name)"
|
|
}
|
|
set v [string trim [$itk_component(table) curvalue] \ \r\n]
|
|
debug "n=$n v=$v"
|
|
if {$v != ""} {
|
|
if {[catch {gdb_cmd "set \$${n}=$v"} result]} {
|
|
tk_messageBox -icon error -type ok -message $result \
|
|
-title "Error in Expression" -parent $_top
|
|
}
|
|
}
|
|
|
|
# Always update the register, even for error conditions. This
|
|
# will ensure that the cell's old value is restored to the table.
|
|
_update_register $_register($cell)
|
|
_size_cell_column $cell 1
|
|
}
|
|
|
|
_unedit
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_add_to_watch
|
|
# DESCRIPTION: Add a register to the watch window
|
|
#
|
|
# ARGUMENTS: rn - the register number to add to the WatchWin
|
|
# RETURNS: Nothing
|
|
#
|
|
# NOTES: Only works with one WatchWin...
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_add_to_watch {rn} {
|
|
[ManagedWin::open WatchWin] add "\$[gdb_reginfo name $rn]"
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_add_to_watch
|
|
# DESCRIPTION: Add a register to the watch window
|
|
#
|
|
# ARGUMENTS: rn - the register number to add to the WatchWin
|
|
# RETURNS: Nothing
|
|
#
|
|
# NOTES: Only works with one WatchWin...
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_open_memory {rn} {
|
|
ManagedWin::open MemWin -force -addr_exp $_data($_cell($rn))
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_but3
|
|
# DESCRIPTION: Configure the popup menu before posting it
|
|
#
|
|
# ARGUMENTS: x - x-coordinate of buttonpress
|
|
# y - y-coordinate
|
|
# X - x-root coordinate
|
|
# Y - y-root coordinate
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_but3 {x y X Y} {
|
|
|
|
# Only post the menu when we're not executing the inferior,
|
|
# the inferior is in a runnable state, and we're not in a disabled
|
|
# cell.
|
|
if {!$_running && $::gdb_running} {
|
|
|
|
# Select the register
|
|
set cell [_select_cell [$itk_component(table) index @$x,$y]]
|
|
if {[info exists _register($cell)]} {
|
|
set rn $_register($cell)
|
|
set name [gdb_reginfo name $rn]
|
|
$itk_component(popup) delete 0 end
|
|
$itk_component(popup) add command -label $name -state disabled
|
|
$itk_component(popup) add separator
|
|
if {[llength $_types($rn)] > 1} {
|
|
foreach t $_types($rn) {
|
|
$itk_component(popup) add radio -label [lindex $t 0] \
|
|
-variable [scope _type($rn,addr)] \
|
|
-value [lindex $t 1] \
|
|
-command [code $this _change_format $rn [lindex $t 0]]
|
|
}
|
|
$itk_component(popup) add separator
|
|
}
|
|
|
|
$itk_component(popup) add radio -label "Hex" \
|
|
-variable [scope _format($rn)] -value x \
|
|
-command [code $this _change_format $rn]
|
|
|
|
if {$_type($rn,code) == "int"} {
|
|
$itk_component(popup) add radio -label "Decimal" \
|
|
-variable [scope _format($rn)] -value d \
|
|
-command [code $this _change_format $rn]
|
|
$itk_component(popup) add radio -label "Unsigned" \
|
|
-variable [scope _format($rn)] -value u \
|
|
-command [code $this _change_format $rn]
|
|
} elseif {$_type($rn,code) == "float"} {
|
|
$itk_component(popup) add radio -label "Floating Point" \
|
|
-variable [scope _format($rn)] -value f \
|
|
-command [code $this _change_format $rn]
|
|
}
|
|
$itk_component(popup) add separator
|
|
|
|
if {$_editable($rn)} {
|
|
set state normal
|
|
} else {
|
|
set state disabled
|
|
}
|
|
|
|
if {$_type($rn,code) == "int"} {
|
|
$itk_component(popup) add command \
|
|
-label "Open Memory Window" -command [code $this _open_memory $rn]
|
|
}
|
|
$itk_component(popup) add command \
|
|
-label "Add to Watch" -command [code $this _add_to_watch $rn]
|
|
$itk_component(popup) add separator
|
|
$itk_component(popup) add command \
|
|
-label "Remove from Display" \
|
|
-command [code $this _delete_from_display $rn]
|
|
if {[llength $_register(hidden)] != 0} {
|
|
$itk_component(popup) add command -label "Display all Registers" \
|
|
-command [code $this _display_all]
|
|
}
|
|
|
|
# Help
|
|
$itk_component(popup) add separator
|
|
$itk_component(popup) add command \
|
|
-label "Help" -command {open_help register.html}
|
|
|
|
# Close
|
|
$itk_component(popup) add separator
|
|
$itk_component(popup) add command -label "Close" \
|
|
-underline 0 -command [code delete object $this]
|
|
|
|
tk_popup $itk_component(popup) $X $Y
|
|
}
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_delete_from_display
|
|
# DESCRIPTION: Remove a register from the display
|
|
#
|
|
# ARGUMENTS: rn - the register number to remove
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_delete_from_display {rn} {
|
|
|
|
# Mark the cell as hidden
|
|
set index [lsearch $_reg_display_list $rn]
|
|
if {$index != -1} {
|
|
pref setd gdb/reg/[gdb_reginfo name $rn] no
|
|
set _reg_display_list [lreplace $_reg_display_list $index $index]
|
|
|
|
# Relayout table
|
|
_layout_table
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_display_all
|
|
# DESCRIPTION: Display all registers in the window
|
|
#
|
|
# ARGUMENTS: None
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_display_all {} {
|
|
|
|
# Unhide all hidden registers
|
|
foreach r $_register(hidden) {
|
|
pref setd gdb/reg/[gdb_reginfo name $r] {}
|
|
}
|
|
|
|
# Note which register is active and restore it
|
|
if {[catch {$itk_component(table) index active} cell]} {
|
|
set active {}
|
|
} else {
|
|
set active $_register($cell)
|
|
}
|
|
_layout_table
|
|
if {$active != ""} {
|
|
$itk_component(table) activate $_cell($active)
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_edit
|
|
# DESCRIPTION: Enables a cell for editing
|
|
#
|
|
# ARGUMENTS:
|
|
# x - the x coordinate of the button press
|
|
# y - the y coordinate of the button press
|
|
# RETURNS: Nothing
|
|
#
|
|
# NOTES: Event handler for <1> in table.
|
|
#
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_edit {x y} {
|
|
_select_cell [$itk_component(table) index @$x,$y]
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method _move
|
|
# DESCRIPTION: Handle arrow key events in table
|
|
#
|
|
# ARGUMENTS: direction - "up", "down", "left", "right"
|
|
# RETURNS: Nothing
|
|
#
|
|
# NOTES: Event handler for <Up>, <Down>, <Left>, <Right>
|
|
# in table. This is needed because the table
|
|
# has some rather strange bindings for moving
|
|
# the insertion cursor when editing a cell.
|
|
# This method will move to the next cell when
|
|
# we're not editing, or it will move the icursor
|
|
# if we are editing.
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_move {direction} {
|
|
|
|
debug $direction
|
|
|
|
# If there is no active cell, the table will call error
|
|
if {[catch {$itk_component(table) index active row} row]} {
|
|
return
|
|
}
|
|
|
|
if {[$itk_component(table) tag cell edit] != ""} {
|
|
# Editing
|
|
|
|
switch $direction {
|
|
up {
|
|
# Go to beginning
|
|
$itk_component(table) icursor 0
|
|
}
|
|
|
|
down {
|
|
# Go to end
|
|
$itk_component(table) icursor end
|
|
}
|
|
|
|
left {
|
|
# Go left one character
|
|
set ic [$itk_component(table) icursor]
|
|
if {$ic > 0} {
|
|
$itk_component(table) icursor [expr {$ic - 1}]
|
|
}
|
|
}
|
|
|
|
right {
|
|
# Go right one character
|
|
set ic [$itk_component(table) icursor]
|
|
if {$ic < [$itk_component(table) icursor end] } {
|
|
$itk_component(table) icursor [expr {$ic + 1}]
|
|
}
|
|
}
|
|
}
|
|
|
|
} else {
|
|
# Not editing
|
|
|
|
set col [$itk_component(table) index active col]
|
|
|
|
switch $direction {
|
|
up {
|
|
incr row -1
|
|
if {$row < 0} {
|
|
# go to bottom
|
|
set row $_rows
|
|
}
|
|
}
|
|
|
|
down {
|
|
incr row 1
|
|
if {$row == $_rows} {
|
|
# go to top
|
|
set row 0
|
|
}
|
|
}
|
|
|
|
left {
|
|
incr col -2
|
|
if {$col < 0} {
|
|
# go to right
|
|
set col [expr {$_cols -1}]
|
|
}
|
|
}
|
|
|
|
right {
|
|
incr col 2
|
|
if {$col > $_cols} {
|
|
# go to left
|
|
set col 0
|
|
}
|
|
}
|
|
}
|
|
|
|
# clear the selection
|
|
# FIXME: multiple selections?
|
|
$itk_component(table) selection clear all
|
|
|
|
_select_cell $row,$col
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_select_cell
|
|
# DESCRIPTION: Selects a given cell in the table
|
|
#
|
|
# ARGUMENTS:
|
|
# cell - the table index to select
|
|
# RETURNS: The actual cell selected
|
|
#
|
|
# NOTES: Adjusts the cell index so that it always
|
|
# selects the value cell for a register
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_select_cell {cell} {
|
|
|
|
# Abort an edit
|
|
_unedit
|
|
|
|
# check if going to label. If so, highlight next
|
|
set row [lindex [split $cell ,] 0]
|
|
set col [lindex [split $cell ,] 1]
|
|
if {[expr {$col % 2}] == 0} {
|
|
# going onto a label
|
|
incr col 1
|
|
}
|
|
set cell "$row,$col"
|
|
|
|
# Make the selected cell the active one
|
|
$itk_component(table) activate $row,$col
|
|
$itk_component(table) see active
|
|
|
|
# Select this cell and its label
|
|
# FIXME: multiple selections?
|
|
$itk_component(table) selection clear all
|
|
$itk_component(table) selection set $cell $row,[expr {$col-1}]
|
|
|
|
# Now mark the cell as being edited.
|
|
if {$::gdb_running && [info exists _register($cell)]} {
|
|
$itk_component(table) tag cell edit $cell
|
|
}
|
|
|
|
focus $itk_component(table)
|
|
|
|
return $cell
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_unedit
|
|
# DESCRIPTION: Cancels an edit
|
|
#
|
|
# ARGUMENTS: None
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_unedit {} {
|
|
|
|
# clear the tag
|
|
set cell [$itk_component(table) tag cell edit]
|
|
|
|
if {$cell != ""} {
|
|
$itk_component(table) selection clear all
|
|
$itk_component(table) tag cell normal $cell
|
|
focus $itk_component(table)
|
|
}
|
|
}
|
|
|
|
#
|
|
# Register operations
|
|
#
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_get_value
|
|
# DESCRIPTION: Get the value of a register
|
|
#
|
|
# ARGUMENTS: rn - the register number whose value should be
|
|
# fetched
|
|
# RETURNS: The register's value or ""
|
|
#
|
|
# NOTES:
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_get_value {rn} {
|
|
if {[catch {gdb_reginfo value $rn} value]} {
|
|
dbug W "\"gdb_reginfo value $rn\" returned $value"
|
|
set value ""
|
|
} else {
|
|
set value [string trim $value \ ]
|
|
}
|
|
return $value
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private method RegWin::_change_format
|
|
# DESCRIPTION: Change the display format of the register
|
|
#
|
|
# ARGUMENTS: rn - the register number to change
|
|
# newtype - type name (optional if just format changed)
|
|
#
|
|
# RETURNS: Nothing
|
|
#
|
|
# NOTES:
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_change_format {rn {newtype {}}} {
|
|
|
|
set name [gdb_reginfo name $rn]
|
|
|
|
if {$newtype != ""} {
|
|
set _type($rn,name) $newtype
|
|
pref setd gdb/reg/${name}-type $newtype
|
|
}
|
|
|
|
gdb_reginfo format $rn $_type($rn,addr) $_format($rn)
|
|
|
|
# Set the new format in prefs.
|
|
pref setd gdb/reg/${name}-format $_format($rn)
|
|
|
|
_update_register $rn
|
|
_size_cell_column $_cell($rn) 1
|
|
|
|
# Show the active cell in case it's moved as a result
|
|
# of resizing the columns.
|
|
$itk_component(table) see active
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private_method RegWin::_update_register
|
|
# DESCRIPTION: Updates the value of a register and refreshes
|
|
# the table
|
|
#
|
|
# ARGUMENTS:
|
|
# rn - the register number to update
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_update_register {rn} {
|
|
set _data($_cell($rn)) [_get_value $rn]
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: private_method RegWin::_select_group
|
|
# DESCRIPTION: Changes the register group. Callback
|
|
#
|
|
# ARGUMENTS:
|
|
#
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::_select_group {} {
|
|
set gr [$itk_component(frame).opt get]
|
|
debug $gr
|
|
if {$gr == ""} {
|
|
return
|
|
}
|
|
|
|
# Change anything on the old change list back to normal
|
|
foreach r $_change_list {
|
|
if {[info exists _cell($r)] && $_cell($r) != "hidden"} {
|
|
$itk_component(table) tag cell normal $_cell($r)
|
|
}
|
|
}
|
|
|
|
set _group $gr
|
|
_layout_table
|
|
|
|
# highlight changed registers if they still exist in the new group
|
|
foreach r $_change_list {
|
|
if {[info exists _cell($r)] && $_cell($r) != "hidden" && $_data($_cell($r)) != ""} {
|
|
$itk_component(table) tag cell highlight $_cell($r)
|
|
}
|
|
}
|
|
|
|
# Clear gdb's change list
|
|
catch {gdb_reginfo changed}
|
|
}
|
|
|
|
|
|
#
|
|
# Gdb Events
|
|
#
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: public method RegWin::arch_changed
|
|
# DESCRIPTION: ArchChangedEvent handler
|
|
#
|
|
# ARGUMENTS: event - the ArchChangedEvent (not used)
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::arch_changed {event} {
|
|
|
|
# Update internal register caches
|
|
gdb_reg_arch_changed
|
|
|
|
# Relayout the table
|
|
_layout_table
|
|
|
|
# Clear gdb's change list
|
|
catch {gdb_reginfo changed}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: public method RegWin::busy
|
|
# DESCRIPTION: BusyEvent handler
|
|
#
|
|
# ARGUMENTS: event - the BusyEvent (not used)
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::busy {event} {
|
|
|
|
# Abort any edit. Need to check if the table is constructed,
|
|
# since we call gdbtk_busy when we're created...
|
|
if {[info exists itk_component(table)]} {
|
|
_unedit
|
|
}
|
|
|
|
# Set fencepost
|
|
set _running 1
|
|
|
|
# Set cursor
|
|
$_top configure -cursor watch
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: public method RegWin::idle
|
|
# DESCRIPTION: IdleEvent handler
|
|
#
|
|
# ARGUMENTS: event - the IdleEvent (not used)
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::idle {event} {
|
|
|
|
# Clear fencepost
|
|
set _running 0
|
|
|
|
# Reset cursor
|
|
$_top configure -cursor {}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: public method RegWin::set_variable
|
|
# DESCRIPTION: SetVariableEvent handler
|
|
#
|
|
# ARGUMENTS: None
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::set_variable {event} {
|
|
switch [$event get variable] {
|
|
disassembly-flavor {
|
|
_layout_table
|
|
}
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# NAME: public method RegWin::update
|
|
# DESCRIPTION: UpdateEvent handler
|
|
#
|
|
# ARGUMENTS: event - the UpdateEvent (not used)
|
|
# RETURNS: Nothing
|
|
# ------------------------------------------------------------------
|
|
itcl::body RegWin::update {event} {
|
|
debug
|
|
|
|
# Change anything on the old change list back to normal
|
|
foreach r $_change_list {
|
|
if {[info exists _cell($r)] && $_cell($r) != "hidden"} {
|
|
$itk_component(table) tag cell normal $_cell($r)
|
|
}
|
|
}
|
|
|
|
# Now update and highlight the newly changed values
|
|
set _change_list {}
|
|
if {![catch {gdb_reginfo changed $_reg_display_list} changed]} {
|
|
set _change_list $changed
|
|
}
|
|
|
|
# Problem: if the register was invalid (i.e, we were not running),
|
|
# its old value will probably be "0x0". Now if we run and its real
|
|
# value is "0x0", then it will appear as a blank in the register
|
|
# window. Safegaurd against that here by adding any such register
|
|
# which is not already in the change list.
|
|
foreach r $_reg_display_list {
|
|
if {$_data($_cell($r)) == "" && [lsearch $_change_list $r] == -1} {
|
|
lappend _change_list $r
|
|
}
|
|
}
|
|
|
|
# Tag the changed cells and resize the columns
|
|
set cols {}
|
|
foreach r $_change_list {
|
|
_update_register $r
|
|
|
|
if {$_data($_cell($r)) != ""} {
|
|
$itk_component(table) tag cell highlight $_cell($r)
|
|
}
|
|
set col [lindex [split $_cell($r) ,] 1]
|
|
if {[lsearch $cols $col] == -1} {
|
|
lappend cols $col
|
|
}
|
|
}
|
|
|
|
foreach col $cols {
|
|
set col [string trim $col ()]
|
|
_size_column $col 0
|
|
}
|
|
|
|
debug "END REGISTER UPDATE CALLBACK"
|
|
}
|