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.
425 lines
14 KiB
Plaintext
425 lines
14 KiB
Plaintext
# Memory display preferences window for Insight.
|
|
# Copyright (C) 1998, 1999, 2002, 2003, 2006 Red Hat
|
|
#
|
|
# This program is free software; you can redistribute it and/or modify it
|
|
# under the terms of the GNU General Public License (GPL) as published by
|
|
# the Free Software Foundation; either version 2 of the License, or (at
|
|
# your option) any later version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: constructor - build the dialog
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::constructor {args} {
|
|
|
|
window_name "Memory Preferences"
|
|
|
|
eval itk_initialize $args
|
|
|
|
if {$float_size == ""} {
|
|
set float_size [gdb_eval sizeof(float)]
|
|
set double_size [gdb_eval sizeof(double)]
|
|
}
|
|
|
|
if {[string compare $format f] == 0} {
|
|
set gformat x
|
|
set format_disabled 1
|
|
if {$size == $float_size} {
|
|
set gsize 3
|
|
} elseif {$size == $double_size} {
|
|
set gsize 5
|
|
}
|
|
} else {
|
|
set gsize $size
|
|
set gformat $format
|
|
}
|
|
|
|
set gnumbytes $numbytes
|
|
set gbpr $bpr
|
|
set gbprlist [list 4 8 16 32 64 128]
|
|
set gascii $ascii
|
|
set gascii_char $ascii_char
|
|
|
|
build_win
|
|
|
|
if {$format_disabled} {
|
|
set format_disabled 0
|
|
disable_format
|
|
}
|
|
|
|
wm resizable [winfo toplevel $itk_interior] 0 0
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: destructor - destroy the dialog
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::destructor {} {
|
|
trace vdelete [scope gnumbytes] w [code $this check_numbytes]
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: build_win - build the dialog
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::build_win {} {
|
|
|
|
frame $itk_interior.f
|
|
set f [frame $itk_interior.f.a]
|
|
frame $itk_interior.f.b
|
|
|
|
# SIZE
|
|
Labelledframe $f.f1 -anchor nw -text Size
|
|
set fr [$f.f1 get_frame]
|
|
|
|
set Widgets(rb-Byte) [radiobutton $fr.1 -variable [scope gsize] -text Byte \
|
|
-value 1 -command [code $this enable_format]]
|
|
set Widgets(rb-half_word) [radiobutton $fr.2 -variable [scope gsize] -text "Half Word" \
|
|
-value 2 -command [code $this enable_format]]
|
|
set Widgets(rb-word) [radiobutton $fr.4 -variable [scope gsize] -text Word \
|
|
-value 4 -command [code $this enable_format]]
|
|
set Widgets(rb-d_word) [radiobutton $fr.8 -variable [scope gsize] -text "Double Word" \
|
|
-value 8 -command [code $this enable_format]]
|
|
set Widgets(rb-float) [radiobutton $fr.f -variable [scope gsize] -text Float \
|
|
-value 3 -command [code $this disable_format]]
|
|
set Widgets(rb-d_float) [radiobutton $fr.d -variable [scope gsize] -text "Double Float" \
|
|
-value 5 -command [code $this disable_format]]
|
|
grid $fr.1 $fr.4 $fr.f -sticky w -padx 4
|
|
grid $fr.2 $fr.8 $fr.d -sticky w -padx 4
|
|
|
|
# FORMAT
|
|
Labelledframe $f.f2 -anchor nw -text Format
|
|
set fr [$f.f2 get_frame]
|
|
set Widgets(rb-binary) [radiobutton $fr.1 -variable [scope gformat] \
|
|
-text Binary -value t]
|
|
set Widgets(rb-octal) [radiobutton $fr.2 -variable [scope gformat] \
|
|
-text Octal -value o]
|
|
set Widgets(rb-hex) [radiobutton $fr.3 -variable [scope gformat] \
|
|
-text Hex -value x]
|
|
set Widgets(rb-signed_dec) [radiobutton $fr.4 -variable [scope gformat] \
|
|
-text "Signed Decimal" -value d]
|
|
set Widgets(rb-unsign_dec) [radiobutton $fr.5 -variable [scope gformat] \
|
|
-text "Unsigned Decimal" -value u]
|
|
|
|
grid $fr.1 $fr.2 $fr.3 -sticky w -padx 4
|
|
grid $fr.4 $fr.5 x -sticky w -padx 4
|
|
|
|
# TOTAL BYTES
|
|
Labelledframe $f.fx -anchor nw -text "Number of Bytes"
|
|
|
|
if {$gnumbytes == 0} {
|
|
set gnumbytes $default_numbytes
|
|
set gvar 0
|
|
} else {
|
|
set gvar 1
|
|
}
|
|
|
|
set fr [$f.fx get_frame]
|
|
set Widgets(rb-win_size) [radiobutton $fr.1 -variable [scope gvar] -text "Depends on window size" \
|
|
-value 0 -command [code $this toggle_size_control]]
|
|
frame $fr.2
|
|
set Widgets(rb-fixed) [radiobutton $fr.2.b -variable [scope gvar] -text Fixed \
|
|
-value 1 -command [code $this toggle_size_control]]
|
|
|
|
set old_numbytes $default_numbytes
|
|
set Widgets(e-numbytes) [entry $fr.2.e -textvariable [scope gnumbytes] -width 3]
|
|
set normal_background [$Widgets(e-numbytes) cget -background]
|
|
|
|
#
|
|
# Trace gnumbytes so it will always be a +'ve integer... Have to set this
|
|
# trace AFTER the widget's textvariable is set so this trace will fire
|
|
# BEFORE the widget's trace.
|
|
#
|
|
|
|
trace variable [scope gnumbytes] w [code $this check_numbytes]
|
|
|
|
label $fr.2.l -text bytes
|
|
grid $fr.2.b $fr.2.e $fr.2.l -sticky we
|
|
grid $fr.1 x -sticky w -padx 4
|
|
grid $fr.2 x -sticky w -padx 4
|
|
grid columnconfigure $fr 1 -weight 1
|
|
|
|
# MISC
|
|
Labelledframe $f.1 -anchor nw -text "Miscellaneous"
|
|
set fr [$f.1 get_frame]
|
|
frame $fr.1
|
|
label $fr.1.plabel -height 1 -width 1 -bg $color -relief raised
|
|
set Widgets(b-color) [button $fr.1.pc -text "Change color..." \
|
|
-command [code $this pick $fr.1.plabel]]
|
|
grid $fr.1.plabel $fr.1.pc
|
|
frame $fr.2
|
|
label $fr.2.l -text "Bytes Per Row "
|
|
set Widgets(b-bytes_per_row) [::combobox::combobox $fr.2.c \
|
|
-command [code $this set_bytes_per_row] \
|
|
-width 4 -editable 1 -font global/fixed \
|
|
-bg $::Colors(textbg)]
|
|
foreach item $gbprlist {
|
|
$fr.2.c list insert end $item
|
|
}
|
|
$fr.2.c configure -value $gbpr
|
|
|
|
pack $fr.2.l -side left -anchor e
|
|
pack $fr.2.c -side right
|
|
|
|
set Widgets(cb-display_ascii) [checkbutton $fr.3 -variable [scope gascii] -text "Display ASCII"]
|
|
frame $fr.4
|
|
set Widgets(e-ascii_char) [entry $fr.4.e -textvariable [scope gascii_char] -width 1]
|
|
label $fr.4.l -text "Control Char"
|
|
grid $fr.4.e $fr.4.l -sticky we
|
|
grid $fr.2 x $fr.3 -sticky w -padx 4
|
|
grid $fr.4 -sticky w -padx 4
|
|
grid columnconfigure $fr 1 -weight 1
|
|
|
|
grid $f.f1 -padx 5 -pady 6 -sticky news
|
|
grid $f.f2 -padx 5 -pady 6 -sticky news
|
|
grid $f.fx -padx 5 -pady 6 -sticky news
|
|
grid $f.1 -padx 5 -pady 6 -sticky we
|
|
|
|
|
|
set Widgets(b-ok) [button $itk_interior.f.b.ok -text OK -command [code $this ok] -width 7 -default active]
|
|
focus $Widgets(b-ok)
|
|
|
|
# If there is an OK button, set Return in the entry field to invoke it...
|
|
|
|
bind $Widgets(e-numbytes) <KeyPress-Return> "$Widgets(b-ok) flash ; $Widgets(b-ok) invoke"
|
|
|
|
set Widgets(b-cancel) [button $itk_interior.f.b.quit -text Cancel -command [code $this cancel] -width 7]
|
|
set Widgets(b-apply) [button $itk_interior.f.b.apply -text Apply -command [code $this apply] -width 7]
|
|
standard_button_box $itk_interior.f.b
|
|
|
|
grid $itk_interior.f.a
|
|
grid $itk_interior.f.b -sticky news
|
|
grid $itk_interior.f
|
|
|
|
#
|
|
# Set the state of the window size entry here...
|
|
#
|
|
toggle_size_control
|
|
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: busy - make the widget unusable
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::busy {} {
|
|
set top [winfo toplevel $itk_interior]
|
|
$top configure -cursor watch
|
|
|
|
# Disable all the radiobuttons and what not
|
|
foreach w [array names Widgets] {
|
|
set WidgetState($w) [$Widgets($w) cget -state]
|
|
}
|
|
foreach w [array names Widgets] {
|
|
$Widgets($w) configure -state disabled
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: idle - make the widget useable
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::idle {} {
|
|
set top [winfo toplevel $itk_interior]
|
|
$top configure -cursor {}
|
|
|
|
# Re-enable all widgets
|
|
foreach w [array names Widgets] {
|
|
$Widgets($w) configure -state $WidgetState($w)
|
|
}
|
|
}
|
|
# ------------------------------------------------------------------
|
|
# METHOD: ok - apply and quit
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::ok {} {
|
|
apply
|
|
unpost
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: cancel - just close the dialog w/o saving changes
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::cancel {} {
|
|
unpost
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: check_numbytes - a trace to make sure gnumbytes is an int > 0
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::check_numbytes {var index mode} {
|
|
upvar \#0 $var true
|
|
if {($true != "") && ([catch {expr {(int($true) != double($true)) || $true <= 0}} val]
|
|
|| $val)} {
|
|
bell
|
|
set true $old_numbytes
|
|
} else {
|
|
set old_numbytes $true
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: set_bytes_per_row - combobox callback to set the bytes per row
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::set_bytes_per_row {w value} {
|
|
if {[string is integer -strict $value] && [expr {$value != 0}]} {
|
|
# The input is a value number.
|
|
set gbpr $value
|
|
set gbpr [string trim $gbpr]
|
|
|
|
# Too high a number will cause a Segmentation fault.
|
|
if {[expr {$gbpr > 150}]} {set gbpr 150}
|
|
|
|
# Insert the value into the combo box list, if it isn't there already.
|
|
set found [lsearch $gbprlist $gbpr]
|
|
|
|
if {$found == -1} {
|
|
lappend gbprlist $gbpr
|
|
$Widgets(b-bytes_per_row) list insert end $gbpr
|
|
}
|
|
|
|
set s $gsize
|
|
if {$s == 3} {set s 4}
|
|
if {$s == 5} {set s 8}
|
|
set rem [expr {$gbpr % $s}]
|
|
if {$rem != 0} {
|
|
# The bytes-per-row is not a multiple of the size.
|
|
set gbpr [expr {$gbpr + ($s - $rem)}]
|
|
}
|
|
}
|
|
|
|
# Set the display to the new value. This may be different if the input
|
|
# was zero or not a number, or if the user entered any whitespace.
|
|
$Widgets(b-bytes_per_row) delete 0 end
|
|
$Widgets(b-bytes_per_row) insert end $gbpr
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: toggle_size_control - toggle the state of the entry box as the
|
|
# control method changes
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::toggle_size_control {} {
|
|
|
|
if {$gvar} {
|
|
$Widgets(e-numbytes) configure -state normal \
|
|
-background $normal_background
|
|
} else {
|
|
$Widgets(e-numbytes) configure -state disabled -background lightgray
|
|
if {[info exists Widgets(b-ok)]} {
|
|
focus $Widgets(b-ok)
|
|
}
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: apply - apply changes to the parent window
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::apply {} {
|
|
|
|
busy
|
|
gdbtk_busy
|
|
|
|
if {$gvar == 0} {
|
|
set numbytes 0
|
|
} elseif {$gnumbytes == "" || $gnumbytes == 0} {
|
|
# Protect against the case where someone sets the
|
|
# entry field to an empty string, or pastes in a 0...
|
|
bell
|
|
set gnumbytes $default_numbytes
|
|
set numbytes $gnumbytes
|
|
} else {
|
|
set numbytes $gnumbytes
|
|
}
|
|
switch $gsize {
|
|
3 {
|
|
set size $float_size
|
|
set format f
|
|
}
|
|
5 {
|
|
set size $double_size
|
|
set format f
|
|
}
|
|
default {
|
|
set size $gsize
|
|
set format $gformat
|
|
}
|
|
}
|
|
|
|
# Ensure the value has been read from the text field.
|
|
set_bytes_per_row "" [$Widgets(b-bytes_per_row) get]
|
|
|
|
# pass all the changed values back to parent
|
|
debug "$win configChange -size $size -numbytes $numbytes \
|
|
-format $format -ascii $gascii \
|
|
-ascii_char $gascii_char -bytes_per_row $gbpr \
|
|
-color $color"
|
|
eval $win configure -size $size -numbytes $numbytes \
|
|
-format $format -ascii $gascii \
|
|
-ascii_char $gascii_char -bytes_per_row $gbpr \
|
|
-color $color
|
|
|
|
$win reconfig
|
|
|
|
gdbtk_idle
|
|
idle
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: enable_format - turn on the format radio buttons
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::enable_format {} {
|
|
# First ensure bytes per row is a multiple of the size.
|
|
# Use the value of the widget, not $gbpr to ensure the typed value is kept.
|
|
set_bytes_per_row "" [$Widgets(b-bytes_per_row) get]
|
|
|
|
if {!$format_disabled} {
|
|
return
|
|
}
|
|
|
|
foreach widget {rb-binary rb-octal rb-hex rb-signed_dec rb-unsign_dec} {
|
|
$Widgets($widget) configure -state normal
|
|
}
|
|
set format_disabled 0
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: disable_format - turn off the format radio buttons
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::disable_format {} {
|
|
# First ensure bytes per row is a multiple of the size.
|
|
# Use the value of the widget, not $gbpr to ensure the typed value is kept.
|
|
set_bytes_per_row "" [$Widgets(b-bytes_per_row) get]
|
|
|
|
if {$format_disabled} {
|
|
return
|
|
}
|
|
|
|
foreach widget {rb-binary rb-octal rb-hex rb-signed_dec rb-unsign_dec} {
|
|
$Widgets($widget) configure -state disabled
|
|
}
|
|
set format_disabled 1
|
|
}
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: pick - pick colors
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::pick {lab} {
|
|
set new_color [tk_chooseColor -initialcolor $color -title "Choose color"]
|
|
if {$new_color != $color && $new_color != ""} {
|
|
set color $new_color
|
|
$lab configure -bg $color
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------
|
|
# METHOD: reconfig - used when preferences change
|
|
# ------------------------------------------------------------------
|
|
itcl::body MemPref::reconfig {} {
|
|
# for now, just delete and recreate
|
|
destroy $itk_interior.f
|
|
build_win
|
|
}
|
|
|