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