| # 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 |
| } |
| |