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.
777 lines
25 KiB
Plaintext
777 lines
25 KiB
Plaintext
# Memory display window class definition for Insight.
|
|
# Copyright (C) 1998, 1999, 2001, 2002, 2005, 2008 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.
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: constructor - build the dialog
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::constructor {args} {
|
|
global _mem
|
|
debug $args
|
|
eval itk_initialize $args
|
|
|
|
set top [winfo toplevel $itk_interior]
|
|
gdbtk_busy
|
|
|
|
set _mem($this,enabled) 1
|
|
|
|
if {![info exists type(1)]} {
|
|
set type(1) char
|
|
set type(2) short
|
|
set type(4) int
|
|
set type(8) "long long"
|
|
}
|
|
|
|
if {[pref getd gdb/mem/menu] != ""} {
|
|
set mbar 0
|
|
}
|
|
|
|
# Load defaults from preferences.
|
|
set size [pref getd gdb/mem/size]
|
|
set numbytes [pref getd gdb/mem/numbytes]
|
|
set format [pref getd gdb/mem/format]
|
|
set ascii [pref getd gdb/mem/ascii]
|
|
set ascii_char [pref getd gdb/mem/ascii_char]
|
|
set bytes_per_row [pref getd gdb/mem/bytes_per_row]
|
|
set color [pref getd gdb/mem/color]
|
|
|
|
init_addr_exp
|
|
build_win
|
|
gdbtk_idle
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: destructor - destroy the dialog
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::destructor {} {
|
|
if {[winfo exists $prefs_win]} {
|
|
$prefs_win cancel
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: build_win - build the main memory window
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::build_win {} {
|
|
global gdb_ImageDir _mem ${this}_memval
|
|
|
|
set maxlen 0
|
|
set maxalen 0
|
|
set saved_value ""
|
|
|
|
if { $mbar } {
|
|
menu $itk_interior.m -tearoff 0
|
|
$top configure -menu $itk_interior.m
|
|
$itk_interior.m add cascade -menu $itk_interior.m.addr \
|
|
-label "Addresses" -underline 0
|
|
set m [menu $itk_interior.m.addr]
|
|
$m add check -label " Auto Update" -variable _mem($this,enabled) \
|
|
-underline 1 -command "after idle $this toggle_enabled"
|
|
$m add command -label " Update Now" -underline 1 \
|
|
-command [code $this _update_address 1] -accelerator {Ctrl+U}
|
|
$m add separator
|
|
$m add command -label " Preferences..." -underline 1 \
|
|
-command "$this create_prefs"
|
|
}
|
|
|
|
# Numcols = number of columns of data
|
|
# numcols = number of columns in table (data plus headings plus ASCII)
|
|
# if numbytes are 0, then use window size to determine how many to read
|
|
if {$numbytes == 0} {
|
|
set Numrows 8
|
|
} else {
|
|
set Numrows [expr {$numbytes / $bytes_per_row}]
|
|
}
|
|
set numrows [expr {$Numrows + 1}]
|
|
|
|
set Numcols [expr {$bytes_per_row / $size}]
|
|
if {$ascii} {
|
|
set numcols [expr {$Numcols + 2}]
|
|
} else {
|
|
set numcols [expr {$Numcols + 1}]
|
|
}
|
|
|
|
itk_component add table {
|
|
::table $itk_interior.t -titlerows 1 -titlecols 1 -variable ${this}_memval \
|
|
-roworigin -1 -colorigin -1 -bg $::Colors(textbg) -fg $::Colors(textfg) \
|
|
-browsecmd "$this changed_cell %s %S" -font global/fixed\
|
|
-colstretch unset -rowstretch unset -selectmode single \
|
|
-xscrollcommand "$itk_interior.sx set" -resizeborders none \
|
|
-cols $numcols -rows $numrows -autoclear 1
|
|
} {
|
|
keep -foreground
|
|
keep -insertbackground
|
|
keep -highlightcolor
|
|
keep -highlightbackground
|
|
}
|
|
|
|
if {$numbytes} {
|
|
$itk_component(table) configure -yscrollcommand "$itk_interior.sy set"
|
|
scrollbar $itk_interior.sy -command [list $itk_component(table) yview]
|
|
} else {
|
|
$itk_component(table) configure -rowstretchmode none
|
|
}
|
|
scrollbar $itk_interior.sx -command [list $itk_component(table) xview] -orient horizontal
|
|
$itk_component(table) tag config sel -bg [$itk_component(table) cget -bg] -relief sunken
|
|
$itk_component(table) tag config active -relief sunken -wrap 0 \
|
|
-bg $::Colors(sbg) -fg $::Colors(sfg)
|
|
$itk_component(table) tag config title -bg $::Colors(bg) -fg $::Colors(fg)
|
|
|
|
# rebind all events that use tkTableMoveCell to our local version
|
|
# because we don't want to move into the ASCII column if it exists
|
|
bind $itk_component(table) <Up> "$this memMoveCell %W -1 0; break"
|
|
bind $itk_component(table) <Down> "$this memMoveCell %W 1 0; break"
|
|
bind $itk_component(table) <Left> "$this memMoveCell %W 0 -1; break"
|
|
bind $itk_component(table) <Right> "$this memMoveCell %W 0 1; break"
|
|
bind $itk_component(table) <Return> "$this memMoveCell %W 0 1; break"
|
|
bind $itk_component(table) <KP_Enter> "$this memMoveCell %W 0 1; break"
|
|
|
|
# bind button 3 to popup
|
|
bind $itk_component(table) <3> "$this do_popup %X %Y"
|
|
|
|
# bind Paste and button2 to the paste function
|
|
# this is necessary because we want to not just paste the
|
|
# data into the cell, but we also have to write it
|
|
# out to real memory
|
|
bind $itk_component(table) <ButtonRelease-2> [format {after idle %s paste %s %s} $this %x %y]
|
|
bind $itk_component(table) <<Paste>> [format {after idle %s paste %s %s} $this %x %y]
|
|
|
|
menu $itk_component(table).menu -tearoff 0
|
|
bind_plain_key $top Control-u [code $this _update_address 1]
|
|
|
|
# bind resize events
|
|
bind $itk_interior <Configure> "$this newsize %h"
|
|
|
|
frame $itk_interior.f
|
|
iwidgets::spinint $itk_interior.f.cntl -labeltext " Address " -width 20 \
|
|
-command "after idle $this update_address_cb" \
|
|
-increment "after idle $this incr_addr -1" \
|
|
-decrement "after idle $this incr_addr 1" -foreground $::Colors(textfg) \
|
|
-validate {} -textbackground $::Colors(textbg)
|
|
$itk_interior.f.cntl delete 0 end
|
|
$itk_interior.f.cntl insert end $addr_exp
|
|
|
|
label $itk_interior.f.endian -text "Target is [gdbtk_endian] endian"
|
|
|
|
balloon register [$itk_interior.f.cntl childsite].uparrow \
|
|
"Scroll Up (Decrement Address)"
|
|
balloon register [$itk_interior.f.cntl childsite].downarrow \
|
|
"Scroll Down (Increment Address)"
|
|
if {!$mbar} {
|
|
button $itk_interior.f.upd -command [code $this _update_address 1] \
|
|
-image [image create photo -file [::file join $gdb_ImageDir check.gif]]
|
|
balloon register $itk_interior.f.upd "Update Now"
|
|
checkbutton $itk_interior.cb -variable _mem($this,enabled) -command "$this toggle_enabled"
|
|
balloon register $itk_interior.cb "Toggles Automatic Display Updates"
|
|
grid $itk_interior.f.upd $itk_interior.f.cntl $itk_interior.f.endian -sticky ew -padx 5
|
|
} else {
|
|
grid $itk_interior.f.cntl x $itk_interior.f.endian -sticky e
|
|
grid columnconfigure $itk_interior.f 1 -weight 1
|
|
}
|
|
|
|
# draw top border
|
|
set col 0
|
|
for {set i 0} {$i < $bytes_per_row} { incr i $size} {
|
|
set ${this}_memval(-1,$col) [format " %X" $i]
|
|
incr col
|
|
}
|
|
|
|
if {$ascii} {
|
|
set ${this}_memval(-1,$col) ASCII
|
|
}
|
|
|
|
# fill initial display
|
|
if {$nb} {
|
|
_update_address 0
|
|
}
|
|
|
|
if {!$mbar} {
|
|
grid $itk_interior.f x -row 0 -column 0 -sticky nws
|
|
grid $itk_interior.cb -row 0 -column 1 -sticky news
|
|
} else {
|
|
grid $itk_interior.f -row 0 -column 0 -sticky news
|
|
}
|
|
grid $itk_component(table) -row 1 -column 0 -sticky news
|
|
if {$numbytes} { grid $itk_interior.sy -row 1 -column 1 -sticky ns }
|
|
grid $itk_interior.sx -sticky ew
|
|
grid columnconfig $itk_interior 0 -weight 1
|
|
grid rowconfig $itk_interior 1 -weight 1
|
|
focus $itk_interior.f.cntl
|
|
|
|
window_name "Memory"
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: paste - paste callback. Update cell contents after paste
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::paste {x y} {
|
|
edit [$itk_component(table) index @$x,$y]
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: validate - because the control widget wants this
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::validate {val} {
|
|
return $val
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: create_prefs - create memory preferences dialog
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::create_prefs {} {
|
|
if {$Running} { return }
|
|
|
|
# make sure row height is set
|
|
if {$rheight == ""} {
|
|
set rheight [lindex [$itk_component(table) bbox 0,0] 3]
|
|
}
|
|
|
|
set prefs_win [ManagedWin::open MemPref -force -over $this\
|
|
-transient -win $this \
|
|
-size $size -format $format -numbytes $numbytes \
|
|
-bpr $bytes_per_row -ascii $ascii \
|
|
-ascii_char $ascii_char -color $color]
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: changed_cell - called when moving from one cell to another
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::changed_cell {from to} {
|
|
#debug "moved from $from to $to"
|
|
#debug "value = [$itk_component(table) get $from]"
|
|
if {$saved_value != ""} {
|
|
if {$saved_value != [$itk_component(table) get $from]} {
|
|
edit $from
|
|
}
|
|
}
|
|
set saved_value [$itk_component(table) get $to]
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: edit - edit a cell
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::edit { cell } {
|
|
global _mem ${this}_memval
|
|
|
|
#debug "edit $cell"
|
|
|
|
if {$Running || $cell == ""} { return }
|
|
set rc [split $cell ,]
|
|
set row [lindex $rc 0]
|
|
set col [lindex $rc 1]
|
|
set val [$itk_component(table) get $cell]
|
|
|
|
if {$col == $Numcols} {
|
|
# editing the ASCII field
|
|
set addr [gdb_incr_addr $current_addr [expr {$bytes_per_row * $row}]]
|
|
set start_addr $addr
|
|
|
|
# calculate number of rows to modify
|
|
set len [string length $val]
|
|
set rows 0
|
|
while {$len > 0} {
|
|
incr rows
|
|
set len [expr {$len - $bytes_per_row}]
|
|
}
|
|
set nb [expr {$rows * $bytes_per_row}]
|
|
|
|
# now process each char, one at a time
|
|
foreach c [split $val ""] {
|
|
if {$c != $ascii_char} {
|
|
scan $c %c char
|
|
if {[catch {gdb_set_mem $addr [format %02x $char] 1} res]} {
|
|
error_dialog $res
|
|
|
|
# reset value
|
|
set ${this}_memval($row,$col) $saved_value
|
|
return
|
|
}
|
|
}
|
|
set addr [gdb_incr_addr $addr]
|
|
}
|
|
set addr $start_addr
|
|
set nextval 0
|
|
# now read back the data and update the widget
|
|
catch {gdb_update_mem ${this}_memval $addr $format $size $nb $bytes_per_row $ascii_char} vals
|
|
return
|
|
}
|
|
|
|
# calculate address based on row and column
|
|
set addr [gdb_incr_addr $current_addr [expr {$bytes_per_row * $row + $size * $col}]]
|
|
#debug " edit $row,$col $addr = $val"
|
|
|
|
# Pad the value with zeros, if necessary
|
|
set s [expr {$size * 2}]
|
|
set val [format "0x%0${s}x" $val]
|
|
|
|
# set memory
|
|
#debug "set_mem $addr $val $size"
|
|
if {[catch {gdb_set_mem $addr $val $size} res]} {
|
|
error_dialog $res
|
|
|
|
# reset value
|
|
set ${this}_memval($row,$col) $saved_value
|
|
return
|
|
}
|
|
|
|
# read it back
|
|
# FIXME - HACK ALERT - This call causes trouble with remotes on Windows.
|
|
# This routine is in fact called from within an idle handler triggered by
|
|
# memMoveCell. Something evil happens in that handler that causes gdb to
|
|
# start writing this changed value into all the visible cells...
|
|
# I have not figured out the cause of this, so for now I commented this
|
|
# line out. It will only matter if the write did not succeed, and this was
|
|
# not a very good way to tell the user about that anyway...
|
|
#
|
|
# catch {gdb_update_mem $addr $format $size $size $size ""} val
|
|
# delete whitespace in response
|
|
set val [string trimright $val]
|
|
set val [string trimleft $val]
|
|
set ${this}_memval($row,$col) $val
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: toggle_enabled - called when enable is toggled
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::toggle_enabled {} {
|
|
global _mem
|
|
|
|
if {$Running} { return }
|
|
if {$_mem($this,enabled)} {
|
|
_update_address 1
|
|
set state normal
|
|
set bg $::Colors(textbg)
|
|
} else {
|
|
set bg $::Colors(bg)
|
|
set state disabled
|
|
}
|
|
$itk_component(table) config -background $bg -state $state
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: update - update widget after every PC change
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::update {event} {
|
|
global _mem
|
|
if {$_mem($this,enabled)} {
|
|
_update_address 0
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: idle - memory window is idle, so enable menus
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::idle {event} {
|
|
# Fencepost
|
|
set Running 0
|
|
|
|
# Cursor
|
|
cursor {}
|
|
|
|
if {[winfo exists $itk_interior.m.addr]} {
|
|
# Enable menus
|
|
if {$mbar} {
|
|
for {set i 0} {$i <= [$itk_interior.m.addr index last]} {incr i} {
|
|
if {[$itk_interior.m.addr type $i] != "separator"} {
|
|
$itk_interior.m.addr entryconfigure $i -state normal
|
|
}
|
|
}
|
|
}
|
|
|
|
# Enable control
|
|
$itk_interior.f.cntl configure -state normal
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: busy - BusyEvent handler
|
|
# Disable menus 'cause we're busy updating things.
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::busy {event} {
|
|
# Fencepost
|
|
set Running 1
|
|
|
|
# cursor
|
|
cursor watch
|
|
|
|
# go away if window is not finished drawing
|
|
if {![winfo exists $itk_interior.f.cntl]} { return }
|
|
|
|
# Disable menus
|
|
if {$mbar} {
|
|
for {set i 0} {$i <= [$itk_interior.m.addr index last]} {incr i} {
|
|
if {[$itk_interior.m.addr type $i] != "separator"} {
|
|
$itk_interior.m.addr entryconfigure $i -state disabled
|
|
}
|
|
}
|
|
}
|
|
|
|
# Disable control
|
|
$itk_interior.f.cntl configure -state disabled
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: newsize - calculate how many rows to display when the
|
|
# window is resized.
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::newsize {height} {
|
|
|
|
if {$dont_size || $Running} {
|
|
return
|
|
}
|
|
|
|
# only add rows if numbytes is zero
|
|
if {$numbytes == 0} {
|
|
::update idletasks
|
|
|
|
# make sure row height is set
|
|
if {$rheight == ""} {
|
|
set rheight [lindex [$itk_component(table) bbox 0,0] 3]
|
|
}
|
|
|
|
set theight [winfo height $itk_component(table)]
|
|
set Numrows [expr {$theight / $rheight}]
|
|
$itk_component(table) configure -rows $Numrows
|
|
_update_address 1
|
|
}
|
|
}
|
|
|
|
itcl::body MemWin::_update_address {make_busy} {
|
|
if {$make_busy} {
|
|
gdbtk_busy
|
|
}
|
|
update_address [string trimleft [$itk_interior.f.cntl get]]
|
|
if {$make_busy} {
|
|
gdbtk_idle
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: update_address_cb - address entry widget callback
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::update_address_cb {} {
|
|
set new_entry 1
|
|
_update_address 1
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: update_address - update address and data displayed
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::update_address {addr} {
|
|
|
|
set bad_expr 0
|
|
set saved_addr $current_addr
|
|
if {[string match {[a-zA-Z_&0-9\*]*} $addr]} {
|
|
# Looks like an expression
|
|
set retVal [catch {gdb_eval "$addr" x} current_addr]
|
|
#debug "retVal=$retVal current_addr=$current_addr"
|
|
if {$retVal || [string match "No symbol*" $current_addr] || \
|
|
[string match "Invalid *" $current_addr]} {
|
|
BadExpr $current_addr
|
|
return
|
|
}
|
|
if {[string match {\{*} $current_addr]} {
|
|
set current_addr [lindex $current_addr 1]
|
|
if {$current_addr == ""} {
|
|
return
|
|
}
|
|
}
|
|
} elseif {[regexp {\$[a-zA-Z_]} $addr]} {
|
|
# Looks like a local variable
|
|
set retVal [catch {gdb_eval "$addr" x} current_addr]
|
|
#debug "retVal=$retVal current_addr=$current_addr"
|
|
if {$retVal} {
|
|
BadExpr $current_addr
|
|
return
|
|
}
|
|
if {$current_addr == "void"} {
|
|
BadExpr "No Local Variable Named \"$addr\""
|
|
return
|
|
}
|
|
} else {
|
|
# something really strange, like "0.1" or ""
|
|
BadExpr "Can't Evaluate \"$addr\""
|
|
return
|
|
}
|
|
|
|
# Check for spaces - this can happen with gdb_eval and $pc, for example.
|
|
set index [string first \ $current_addr]
|
|
if {$index != -1} {
|
|
incr index -1
|
|
set current_addr [string range $current_addr 0 $index]
|
|
}
|
|
|
|
set addr_exp $addr
|
|
|
|
# set table background
|
|
$itk_component(table) config -bg $::Colors(textbg) -state normal
|
|
catch {update_addr}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: BadExpr - handle a bad expression
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::BadExpr {errTxt} {
|
|
if {$new_entry} {
|
|
tk_messageBox -type ok -icon error -message $errTxt
|
|
set new_entry 0
|
|
}
|
|
# set table background to gray
|
|
$itk_component(table) config -bg $::Colors(bg) -state disabled
|
|
set current_addr $saved_addr
|
|
set saved_addr ""
|
|
set bad_expr 1
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: incr_addr - callback from control widget to increment
|
|
# the current address.
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::incr_addr {num} {
|
|
if {$current_addr == ""} {
|
|
return
|
|
}
|
|
set old_addr $current_addr
|
|
set current_addr [gdb_incr_addr $current_addr [expr {$bytes_per_row * $num}]]
|
|
|
|
# A memory address less than zero is probably not a good thing...
|
|
#
|
|
|
|
if {($num < 0 && [gdb_eval "$current_addr > $old_addr"]) \
|
|
||($num > 0 && [gdb_eval "$current_addr < $old_addr"]) } {
|
|
bell
|
|
set current_addr $old_addr
|
|
return
|
|
}
|
|
$itk_component(table) config -bg $::Colors(textbg) -state normal
|
|
$itk_interior.f.cntl clear
|
|
$itk_interior.f.cntl insert 0 $current_addr
|
|
_update_address 1
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: update_addr - read in data starting at $current_addr
|
|
# This is just a helper function for update_address.
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::update_addr {} {
|
|
global _mem ${this}_memval
|
|
|
|
set row 0
|
|
|
|
if {$numbytes == 0} {
|
|
set nb [expr {$Numrows * $bytes_per_row}]
|
|
} else {
|
|
set nb $numbytes
|
|
}
|
|
if {$ascii} {
|
|
set retVal [catch {gdb_update_mem ${this}_memval $current_addr $format $size $nb $bytes_per_row $ascii_char} vals]
|
|
|
|
} else {
|
|
set retVal [catch {gdb_update_mem ${this}_memval $current_addr $format $size $nb $bytes_per_row} vals]
|
|
}
|
|
|
|
|
|
if {$retVal || [llength $vals] != 3} {
|
|
BadExpr "Couldn't get memory at address: \"$addr\""
|
|
debug "gdb_update_mem returned return code: $retVal and value: \"$vals\""
|
|
return
|
|
}
|
|
# set default column width to the max in the data columns
|
|
$itk_component(table) configure -colwidth [lindex $vals 1]
|
|
|
|
# set border column width
|
|
$itk_component(table) width -1 [lindex $vals 0]
|
|
|
|
# set ascii column width
|
|
if {$ascii} {
|
|
$itk_component(table) width $Numcols [lindex $vals 2]
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: hidemb - hide the menubar. NOT CURRENTLY USED
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::hidemb {} {
|
|
set mbar 0
|
|
reconfig
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: reconfig - used when preferences change
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::reconfig {} {
|
|
debug
|
|
set addr_exp [string trimright [string trimleft $addr_exp]]
|
|
set wh [winfo height $top]
|
|
|
|
if [winfo exists $itk_interior.m] { destroy $itk_interior.m }
|
|
if [winfo exists $itk_interior.cb] { destroy $itk_interior.cb }
|
|
if [winfo exists $itk_interior.f.upd] { destroy $itk_interior.f.upd }
|
|
if [winfo exists $itk_interior.sy] { destroy $itk_interior.sy }
|
|
destroy $itk_interior.f.cntl $itk_interior.f $itk_component(table) \
|
|
$itk_interior.sx
|
|
|
|
set dont_size 1
|
|
|
|
# If the fonts change, then you will need to recompute the
|
|
# row height. Ditto for switch from fixed number of rows to
|
|
# depends on size.
|
|
|
|
set rheight ""
|
|
|
|
# Update preferences to reflect new reality
|
|
pref setd gdb/mem/size $size
|
|
pref setd gdb/mem/numbytes $numbytes
|
|
pref setd gdb/mem/format $format
|
|
pref setd gdb/mem/ascii $ascii
|
|
pref setd gdb/mem/ascii_char $ascii_char
|
|
pref setd gdb/mem/bytes_per_row $bytes_per_row
|
|
pref setd gdb/mem/color $color
|
|
|
|
build_win
|
|
set dont_size 0
|
|
::update
|
|
|
|
if {$numbytes == 0} {
|
|
newsize $wh
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: do_popup - Display popup menu
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::do_popup {X Y} {
|
|
if {$Running} { return }
|
|
$itk_component(table).menu delete 0 end
|
|
$itk_component(table).menu add check -label "Auto Update" -variable _mem($this,enabled) \
|
|
-underline 0 -command "$this toggle_enabled"
|
|
$itk_component(table).menu add command -label "Update Now" -underline 0 \
|
|
-command [code $this _update_address 1]
|
|
$itk_component(table).menu add command -label "Go To [$itk_component(table) curvalue]" -underline 0 \
|
|
-command "$this goto [$itk_component(table) curvalue]"
|
|
$itk_component(table).menu add command -label "Open New Window at [$itk_component(table) curvalue]" -underline 0 \
|
|
-command [list ManagedWin::open MemWin -force -addr_exp [$itk_component(table) curvalue]]
|
|
$itk_component(table).menu add separator
|
|
$itk_component(table).menu add command -label "Preferences..." -underline 0 \
|
|
-command "$this create_prefs"
|
|
tk_popup $itk_component(table).menu $X $Y
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: goto - change the address of the current memory window
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::goto { addr } {
|
|
set current_addr $addr
|
|
$itk_interior.f.cntl delete 0 end
|
|
$itk_interior.f.cntl insert end $addr
|
|
_update_address 1
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: init_addr_exp - initialize address expression
|
|
# On startup, if the public variable "addr_exp" was not set,
|
|
# then set it to the start of ".data" if found, otherwise "$pc"
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::init_addr_exp {} {
|
|
if {$addr_exp == ""} {
|
|
set err [catch {gdb_cmd "info file"} result]
|
|
if {!$err} {
|
|
foreach line [split [string trim $result] \n] {
|
|
if {[scan $line {%x - %x is %s} start stop section] == 3} {
|
|
if {$section == ".data"} {
|
|
set addr_exp [format "%#08x" $start]
|
|
break
|
|
}
|
|
}
|
|
}
|
|
}
|
|
if {$addr_exp == ""} {
|
|
set addr_exp \$pc
|
|
}
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: cursor - set the cursor
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemWin::cursor {glyph} {
|
|
# Set cursor for all labels
|
|
# for {set i 0} {$i < $bytes_per_row} {incr i $size} {
|
|
# $itk_component(table).h.$i configure -cursor $glyph
|
|
# }
|
|
$top configure -cursor $glyph
|
|
}
|
|
|
|
# memMoveCell --
|
|
#
|
|
# Moves the location cursor (active element) by the specified number
|
|
# of cells and changes the selection if we're in browse or extended
|
|
# selection mode.
|
|
#
|
|
# Don't allow movement into the ASCII column.
|
|
#
|
|
# Arguments:
|
|
# w - The table widget.
|
|
# x - +1 to move down one cell, -1 to move up one cell.
|
|
# y - +1 to move right one cell, -1 to move left one cell.
|
|
|
|
itcl::body MemWin::memMoveCell {w x y} {
|
|
if {[catch {$w index active row} r]} return
|
|
set c [$w index active col]
|
|
if {$ascii && ($c == $Numcols)} {
|
|
# we're in the ASCII column so behave differently
|
|
if {$y == 1} {set x 1}
|
|
if {$y == -1} {set x -1}
|
|
incr r $x
|
|
} else {
|
|
incr r $x
|
|
incr c $y
|
|
if { $c < 0 } {
|
|
if {$r == 0} {
|
|
set c 0
|
|
} else {
|
|
set c [expr {$Numcols - 1}]
|
|
incr r -1
|
|
}
|
|
} elseif { $c >= $Numcols } {
|
|
if {$r >= [expr {$Numrows - 1}]} {
|
|
set c [expr {$Numcols - 1}]
|
|
} else {
|
|
set c 0
|
|
incr r
|
|
}
|
|
}
|
|
}
|
|
if { $r < 0 } { set r 0 }
|
|
$w activate $r,$c
|
|
$w see active
|
|
}
|
|
|
|
# ------------------------------------------------------------
|
|
# PUBLIC METHOD: error_dialog - Open and error dialog.
|
|
# Arguments:
|
|
# msg - The message to display in the dialog
|
|
# modality - The dialog modailty. Default: task
|
|
# type - The dialog type (tk_messageBox).
|
|
# Default: ok
|
|
# ------------------------------------------------------------
|
|
itcl::body MemWin::error_dialog {msg {modality task} {type ok}} {
|
|
set parent [winfo toplevel [namespace tail $this]]
|
|
tk_messageBox -icon error -title Error -type $type \
|
|
-message $msg -parent $parent
|
|
}
|
|
|