# Memory display window class definition for Insight. # Copyright (C) 1998, 1999, 2001, 2002, 2005 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 tcl_platform 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) "$this memMoveCell %W -1 0; break" bind $itk_component(table) "$this memMoveCell %W 1 0; break" bind $itk_component(table) "$this memMoveCell %W 0 -1; break" bind $itk_component(table) "$this memMoveCell %W 0 1; break" bind $itk_component(table) "$this memMoveCell %W 0 1; break" bind $itk_component(table) "$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) [format {after idle %s paste %s %s} $this %x %y] bind $itk_component(table) <> [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 "$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 }