itcl::class VariableWin {
inherit EmbeddedWin GDBWin
protected variable Sizebox 1
constructor {args} {
gdbtk_busy
set _queue [Queue \ build_win $itk_interior
gdbtk_idle
add_hook gdb_no_inferior_hook "$this no_inferior"
add_hook gdb_clear_file_hook [code $this clear_file]
add_hook file_changed_hook [code $this clear_file]
}
method build_win {f} {
global tcl_platform Display
set width [font measure global/fixed "W"]
set width [expr {40 * $width}]
if {$tcl_platform(platform) == "windows"} {
set scrollmode both
} else {
set scrollmode auto
}
debug "tree=$f.tree"
set Tree [tixTree $f.tree \
-opencmd "$this open" \
-closecmd "$this close" \
-ignoreinvoke 1 \
-width $width \
-browsecmd [list $this selectionChanged] \
-scrollbar $scrollmode \
-sizebox $Sizebox]
if {![pref get gdb/mode]} {
$Tree configure -command [list $this editEntry]
}
set Hlist [$Tree subwidget hlist]
$Hlist configure -header 1
set l [expr {$EntryLength - $Length - [string length "Name"]}]
set blank " "
$Hlist header create 0 -itemtype text -headerbackground $::Colors(bg) \
-text "Name[string range $blank 0 $l]Value"
set width [font measure global/fixed $LengthString]
$Hlist configure -indent $width \
-bg $::Colors(textbg) -fg $::Colors(textfg) \
-selectforeground $::Colors(textfg) -selectbackground $::Colors(textbg) \
-selectborderwidth 0 -separator . -font global/fixed
set normal_fg [$Hlist cget -fg]
set highlight_fg $::Colors(sfg)
set disabled_fg red
set NormalTextStyle [tixDisplayStyle text -refwindow $Hlist \
-bg $::Colors(textbg) -font global/fixed]
set HighlightTextStyle [tixDisplayStyle text -refwindow $Hlist \
-bg $::Colors(hbg) -font global/fixed]
set DisabledTextStyle [tixDisplayStyle text -refwindow $Hlist \
-bg green -fg red -font global/fixed]
if {[catch {gdb_cmd "show output-radix"} msg]} {
set Radix 10
} else {
regexp {[0-9]+} $msg Radix
}
update dummy
pack $Tree -expand yes -fill both
bind $Hlist <3> "$this postMenu %X %Y"
bind $Hlist <KeyPress-space> [code $this toggleView]
set Popup [menu $f.menu -tearoff 0]
set disabled_foreground red
$Popup configure -disabledforeground $disabled_foreground
set ViewMenu [menu $Popup.view]
$ViewMenu add radiobutton -label "Hex" -variable Display($this) \
-value hexadecimal
$ViewMenu add radiobutton -label "Decimal" -variable Display($this) \
-value decimal
$ViewMenu add radiobutton -label "Binary" -variable Display($this) \
-value binary
$ViewMenu add radiobutton -label "Octal" -variable Display($this) \
-value octal
$ViewMenu add radiobutton -label "Natural" -variable Display($this) \
-value natural
$Popup add command -label "dummy" -state disabled
$Popup add separator
$Popup add cascade -label "Format" -menu $ViewMenu
if {![pref get gdb/mode]} {
$Popup add command -label "Edit"
}
selectionChanged ""
window_name "Local Variables" "Locals"
}
destructor {
catch {destroy $_frame}
destroy $NormalTextStyle
destroy $HighlightTextStyle
destroy $DisabledTextStyle
remove_hook gdb_no_inferior_hook "$this no_inferior"
remove_hook gdb_clear_file_hook [code $this clear_file]
remove_hook file_changed_hook [code $this clear_file]
}
method clear_file {} {
no_inferior
}
method reconfig {} {
foreach win [winfo children $itk_interior] {
destroy $win
}
build_win $itk_interior
}
method build_menu_helper {first} {
global Display
menu [namespace tail $this].mmenu
[namespace tail $this].mmenu add cascade -label $first -underline 0 -menu [namespace tail $this].mmenu.var
menu [namespace tail $this].mmenu.var
if {![pref get gdb/mode]} {
[namespace tail $this].mmenu.var add command -label Edit -underline 0 -state disabled \
-command [format {
%s editEntry [%s getSelection]
} $this $this]
}
[namespace tail $this].mmenu.var add cascade -label Format -underline 0 -state disabled \
-menu [namespace tail $this].mmenu.var.format
menu [namespace tail $this].mmenu.var.format
foreach label {Hex Decimal Binary Octal Natural} fmt {hexadecimal decimal binary octal natural} {
[namespace tail $this].mmenu.var.format add radiobutton \
-label $label -underline 0 \
-value $fmt -variable Display($this) \
-command [format {
%s setDisplay [%s getSelection] %s
} $this $this $fmt]
}
set top [winfo toplevel [namespace tail $this]]
$top configure -menu [namespace tail $this].mmenu
bind_plain_key $top Control-u [format {
if {!$Running} {
if {[%s getSelection] != ""} {
%s updateNow [%s getSelection]
}
}
} $this $this $this]
return [namespace tail $this].mmenu.var
}
method getSelection {} {
return [$Hlist info selection]
}
method selectionChanged {variable} {
global Display
if {$Running} {
$Hlist selection clear
return
}
if {[info exists EditEntry]} {
UnEdit
}
if {$variable == ""} {
set state disabled
} else {
set state normal
}
foreach menu [list [namespace tail $this].mmenu.var [namespace tail $this].mmenu.var.format ] {
set i [$menu index last]
while {$i >= 0} {
if {[$menu type $i] != "cascade"} {
$menu entryconfigure $i -state $state
}
incr i -1
}
}
if {$variable != "" && [$variable editable]} {
set state normal
} else {
set state disabled
}
if {$variable != ""} {
set Display($this) [$variable format]
}
foreach label {Hex Decimal Binary Octal Natural} {
[namespace tail $this].mmenu.var.format entryconfigure $label
if {$label != "Hex"} {
[namespace tail $this].mmenu.var.format entryconfigure $label -state $state
}
}
}
method updateNow {variable} {
if {!$Running} {
set text [label $variable]
$Hlist entryconfigure $variable -itemtype text -text $text
}
}
method getEntry {x y} {
set realY [expr {$y - [winfo rooty $Hlist]}]
return [$Hlist nearest $realY]
}
method editEntry {variable} {
if {!$Running} {
if {$variable != "" && [$variable editable]} {
edit $variable
}
}
}
method postMenu {X Y} {
global Update Display
if {[winfo ismapped $Popup] || $Running} {
return
}
set variable [getEntry $X $Y]
if {[string length $variable] > 0} {
$Hlist selection set $variable
set viewIndex [$Popup index "Format"]
set noEdit [catch {$Popup index "Edit"} editIndex]
$Popup entryconfigure 0 -label "[$variable name]"
if {$variable != "" && [$variable editable]} {
if {!$noEdit} {
$Popup delete $editIndex
}
if {![pref get gdb/mode]} {
$Popup add command -label Edit -command "$this edit \{$variable\}"
}
} else {
if {!$noEdit} {
$Popup delete $editIndex
}
}
set Display($this) [$variable format]
foreach i {0 1 2 3 4} fmt {hexadecimal decimal binary octal natural} {
debug "configuring entry $i ([$ViewMenu entrycget $i -label]) to $fmt"
$ViewMenu entryconfigure $i \
-command "$this setDisplay \{$variable\} $fmt"
}
if {$::tcl_platform(platform) == "windows"} {
set no [$Popup index end]
for { set k 1 } { $k < $no } { incr k } {
$Popup insert 1 command
}
$Popup delete 1 [expr {$no - 1}]
}
tk_popup $Popup $X $Y
}
}
method edit {variable} {
global Update
selectionChanged ""
debug "editing \"$variable\""
set fg [$Hlist cget -foreground]
set bg [$Hlist cget -background]
if {$Editing == ""} {
set Editing [frame $Hlist.frame -bg $bg -bd 0 -relief flat]
set lbl [::label $Editing.lbl -fg $fg -bg $bg -font global/fixed]
set ent [entry $Editing.ent -bg $::Colors(bg) -fg $::Colors(fg) -font global/fixed]
pack $lbl $ent -side left
}
if {[info exists EditEntry]} {
UnEdit
}
set Update($this,$variable) 1
set EditEntry $variable
set label [label $variable 1]; $Editing.lbl configure -text "$label "
$Editing.ent delete 0 end
set err [catch {$variable value} text]
if {$err} {return}
if {[$variable format] == "natural"} {
set index [string first \ $text]
if {$index != -1} {
set text [string range $text 0 [expr {$index - 1}]]
}
}
$Editing.ent insert 0 $text
set previous [getPrevious $variable]
$Hlist delete entry $variable
set cmd [format { \
%s add {%s} %s -itemtype window -window %s \
} $Hlist $variable $previous $Editing]
eval $cmd
if {[$variable numChildren] > 0} {
$Tree setmode $variable open
}
focus $Editing.ent
$Editing.ent selection to end
bind $Editing.ent <Return> "$this changeValue"
bind $Hlist <Return> "$this changeValue"
bind $Editing.ent <Escape> "$this UnEdit"
bind $Hlist <Escape> "$this UnEdit"
}
method getPrevious {variable} {
set prev [$Hlist info prev $variable]
set parent [$Hlist info parent $variable]
if {$prev != ""} {
if {[$Hlist info parent $prev] != $parent} {
set children [$Hlist info children $parent]
set p {}
foreach child $children {
if {$child == $variable} {
break
}
set p $child
}
if {$p == {}} {
set previous "-before [lindex $children 1]"
} else {
set previous "-after $p"
}
} else {
set previous "-after \{$prev\}"
}
} else {
set previous "-at 0"
}
if {$prev == "$parent"} {
set previous "-at 0"
}
return $previous
}
method UnEdit {} {
set previous [getPrevious $EditEntry]
$Hlist delete entry $EditEntry
set cmd [format {\
%s add {%s} %s -itemtype text -text {%s} \
} $Hlist $EditEntry $previous [label $EditEntry]]
eval $cmd
if {[$EditEntry numChildren] > 0} {
$Tree setmode $EditEntry open
}
bind $Hlist <Return> {}
bind $Hlist <Escape> {}
if {$Editing != ""} {
bind $Editing.ent <Return> {}
bind $Editing.ent <Escape> {}
}
unset EditEntry
selectionChanged ""
}
method changeValue {} {
set new [string trim [$Editing.ent get] \ \r\n]
if {$new == ""} {
UnEdit
return
}
if {[catch {$EditEntry value $new} errTxt]} {
tk_messageBox -icon error -type ok -message $errTxt \
-title "Error in Expression" -parent [winfo toplevel $itk_interior]
focus $Editing.ent
$Editing.ent selection to end
} else {
UnEdit
gdbtk_update
focus $Tree
}
}
method toggleView {} {
set v [getSelection]
set mode [$Tree getmode $v]
debug "mode=$mode"
switch $mode {
open {
$Tree setmode $v close
open $v
}
close {
$Tree setmode $v open
close $v
}
default {
dbug E "What happened?"
}
}
}
method toggleUpdate {variable} {
global Update
debug $variable
if {$Update($this,$variable)} {
debug NORMAL
$Hlist entryconfigure $variable \
-style $NormalTextStyle \
-text [label $variable]
} else {
debug DISABLED
$Hlist entryconfigure $variable \
-style $DisabledTextStyle
}
::update
}
method setDisplay {variable format} {
debug "$variable $format"
if {!$Running} {
$variable format $format
set ::Display($this) $format
$Hlist entryconfigure $variable -text [label $variable]
}
}
method label {variable {noValue 0}} {
set blank " "
set name [$variable name]
set indent [llength [split $variable .]]
set indent [expr {$indent * $Length}]
set len [string length $name]
set l [expr {$EntryLength - $len - $indent}]
set label "$name[string range $blank 0 $l]"
if {$noValue} {
return $label
}
set err [catch {$variable value} value]
set value [string trim $value \ \r\t\n]
set type [$variable type]
if {!$err} {
if {$value == "{...}"} {
set val " $type $value"
} elseif {[string first * $type] != -1} {
set val " ($type) $value"
} elseif {[string first \[ $type] != -1} {
set val " $type"
} else {
set val " $value"
}
} else {
set val " $value"
}
return "$label $val"
}
method open {path} {
global Update
if {[info exists EditEntry]} {
UnEdit
}
if {!$Running} {
if {$Update($this,$path)} {
cursor watch
populate $path
cursor {}
}
} else {
$Tree setmode $path open
}
}
method close {path} {
global Update
debug "$path"
if {[info exists EditEntry]} {
UnEdit
}
if {!$Running} {
if {$Update($this,$path)} {
$Hlist delete offspring $path
}
} else {
$Tree setmode $path close
}
}
method isVariable {var} {
set err [catch {gdb_cmd "output $var"} msg]
if {$err
|| [regexp -nocase "no symbol|syntax error" $msg]} {
return 0
}
return 1
}
method getVariablesBlankPath {} {
dbug -W "You forgot to override getVariablesBlankPath!!"
return {}
}
method cmd {cmd} {
eval $cmd
}
method populate {parent} {
global Update
debug "$parent"
if {[string length $parent] == 0} {
set variables [getVariablesBlankPath]
} else {
set variables [$parent children]
}
debug "variables=$variables"
eval $_queue push $variables
for {set variable [$_queue pop]} {$variable != ""} {set variable [$_queue pop]} {
debug "inserting variable: $variable"
set Update($this,$variable) 1
$Hlist add $variable \
-itemtype text \
-text [label $variable]
if {[$variable numChildren] > 0} {
$Tree setmode $variable open
}
if {[string compare [$variable name] "public"] == 0
&& [$variable type] == "" && [$variable value] == ""} {
eval $_queue push [$variable children]
$Tree setmode $variable close
}
}
debug "done with populate"
}
proc getLocals {} {
set vars {}
set err [catch {gdb_get_args} v]
if {!$err} {
set vars [concat $vars $v]
}
set err [catch {gdb_get_locals} v]
if {!$err} {
set vars [concat $vars $v]
}
debug "--getLocals:\n$vars\n--getLocals"
return [lsort $vars]
}
method context_switch {} {
set err [catch {gdb_selected_frame} current_frame]
debug "1: err=$err; _frame=\"$_frame\"; current_frame=\"$current_frame\""
if {$err && $_frame != ""} {
debug "no current frame"
catch {destroy $_frame}
set _frame {}
return 1
} elseif {$current_frame == "" && $_frame == ""} {
debug "2"
return 0
} elseif {$_frame == "" || $current_frame != [$_frame address]} {
debug "switching to frame at $current_frame"
catch {destroy $_frame}
set _frame [Frame ::\ debug "created new frame: $_frame at [$_frame address]"
return 1
}
debug "3"
return 0
}
method update {event} {
global Update
debug
foreach w $ChangeList {
catch {
$Hlist entryconfigure $w -style $NormalTextStyle
}
}
set ChangeList {}
set variables [$Hlist info children {}]
foreach var $variables {
set numchild [$var numChildren]
set UpdatedList [$var update]
if {([lindex $UpdatedList 0] == $var)
&& ($numchild > 0)} {
debug "Type changed."
$Hlist delete offsprings $var
$Hlist entryconfigure $var -text [label $var]
if {[$var numChildren] > 0} {
$Tree setmode $var open
} else {
$Tree setmode $var none
}
} else {
set ChangeList [concat $ChangeList $UpdatedList]
}
}
foreach var $ChangeList {
debug "$var HIGHLIGHT"
$Hlist entryconfigure $var \
-style $HighlightTextStyle \
-text [label $var]
}
}
method idle {event} {
enable_ui
}
method displayedVariables {top} {
set variableList {}
set variables [$Hlist info children $top]
foreach var $variables {
set mode [$Tree getmode $var]
if {$mode == "close"} {
set moreVars [displayedVariables $var]
lappend variableList [join $moreVars]
}
lappend variableList $var
}
return [join $variableList]
}
method deleteTree {} {
global Update
debug
$Hlist delete all
}
method enable_ui {} {
set Running 0
cursor {}
}
method busy {event} {
set Running 1
if {[info exists EditEntry]} {
UnEdit
}
cursor watch
}
method no_inferior {} {
deleteTree
set Running 0
set _frame {}
cursor {}
}
method cursor {what} {
[winfo toplevel [namespace tail $this]] configure -cursor $what
::update idletasks
}
protected variable Tree {}
protected variable Hlist {}
protected variable ChangeList {}
protected variable ViewMenu
protected variable Popup
common EntryLength 15
common Length 1
common LengthString " "
protected variable HighlightTextStyle
protected variable NormalTextStyle
protected variable DisabledTextStyle
protected variable Radix
protected variable _frame {}
protected variable Editing {}
protected variable EditEntry
protected variable Running 0
protected variable _queue {}
}