# Paned text widget for source code, for Insight
# Copyright 1997, 1998, 1999, 2001, 2002 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.
# ----------------------------------------------------------------------
# Implements the paned text widget with the source code in it.
# This widget is typically embedded in a SrcWin widget.
#
# ----------------------------------------------------------------------
# ------------------------------------------------------------------
# CONSTRUCTOR - create new source text window
# ------------------------------------------------------------------
itcl::body SrcTextWin::constructor {args} {
eval itk_initialize $args
set top [winfo toplevel $itk_interior]
if {$parent == {}} {
set parent [winfo parent $itk_interior]
}
if {![info exists break_images(bp)]} {
set size [font measure [pref get gdb/src/font] "W"]
set break_images(bp) [makeBreakDot $size \
[pref get gdb/src/bp_fg]]
set break_images(temp_bp) [makeBreakDot $size \
[pref get gdb/src/temp_bp_fg]]
set break_images(disabled_bp) [makeBreakDot $size \
[pref get gdb/src/disabled_fg]]
set break_images(tp) [makeBreakDot $size \
[pref get gdb/src/trace_fg]]
set break_images(thread_bp) [makeBreakDot $size \
[pref get gdb/src/thread_fg]]
set break_images(bp_and_tp) [makeBreakDot $size \
[list [pref get gdb/src/trace_fg] \
[pref get gdb/src/bp_fg]]]
}
if {$ignore_var_balloons} {
set UseVariableBalloons 0
} else {
set UseVariableBalloons [pref get gdb/src/variableBalloons]
}
set Linenums [pref get gdb/src/linenums]
#Initialize state variables
_initialize_srctextwin
build_popups
build_win
# add hooks
if {$Tracing} {
add_hook control_mode_hook "$this set_control_mode"
add_hook gdb_trace_find_hook "$this trace_find_hook"
}
if {$UseVariableBalloons} {
add_hook gdb_idle_hook "$this updateBalloon"
}
global ${this}_balloon
trace variable ${this}_balloon w "$this trace_help"
}
# ------------------------------------------------------------------
# DESTRUCTOR - destroy window containing widget
# ------------------------------------------------------------------
itcl::body SrcTextWin::destructor {} {
if {$Tracing} {
remove_hook control_mode_hook "$this set_control_mode"
}
if {$UseVariableBalloons} {
remove_hook gdb_idle_hook "$this updateBalloon"
}
}
# ------------------------------------------------------------------
# METHOD: trace_find_hook - response to the tfind command. All we
# need to do here is to remove the trace tags, if we are exiting
# trace mode
# ------------------------------------------------------------------
itcl::body SrcTextWin::trace_find_hook {mode from_tty} {
if {[string compare $mode -1] == 0} {
if {$Browsing} {
$twin tag remove STACK_TAG 1.0 end
}
}
}
# ------------------------------------------------------------------
# METHOD: set_control_mode- switches the src window between
# browsing -> mode = 1
# controlling -> mode = 0
# ------------------------------------------------------------------
itcl::body SrcTextWin::set_control_mode {mode} {
# debug "Setting control mode of $twin to $mode"
if {$mode} {
set Browsing 1
} else {
set Browsing 0
}
switch $current(mode) {
SOURCE {
config_win $twin
}
ASSEMBLY {
config_win $twin A
}
MIXED {
config_win $twin M
}
SRC+ASM {
config_win $twin
config_win $bwin A
}
}
}
# ------------------------------------------------------------------
# METHOD: build_popups - build the popups for the source window(s)
# ------------------------------------------------------------------
#
# The popups array holds the data for the breakpoint & tracepoint popup menus.
# The elements are:
# Menus:
# break_rgn - the popup for clicking in a bare break region
# bp - the popup for clicking on a set breakpoint
# tp - the popup for clicking on a set tracepoint
# bp_and_tp - the popup for clicking on the break_region when the
# line contains both a bp & a tp
# source - the popup for clicking on the source region of the window
#
# State:
# saved_y - the y value of the mouse click that posted the popup
# saved_win- the Tk window which recieved the posting click
#
# Disable info:
# run_disabled - a list of {menu entry} pairs for all the menus that
# should be disabled when you are not running
# browse_disabled - a similar list for menus that should be disabled
# when you are browsing a trace expt.
#
itcl::body SrcTextWin::build_popups {} {
set popups(bp) $itk_interior.bp_menu
set popups(tp) $itk_interior.tp_menu
set popups(bp_and_tp) $itk_interior.tp_bp_menu
set popups(tp_browse) $itk_interior.tp_browse_menu
set popups(break_rgn) $itk_interior.break_menu
set popups(source) $itk_interior.src_menu
set popups(disabled_bp) $itk_interior.disabled_bp_menu
# This is a scratch popup menu we use when we are not over a bp...
if {![winfo exists $popups(source)]} {
menu $popups(source) -tearoff 0
}
if {![winfo exists $popups(break_rgn)]} {
# breakpoint popup menu
# don't enable hardware or conditional breakpoints until they are tested
menu $popups(break_rgn) -tearoff 0
set bp_fg [pref get gdb/src/bp_fg]
set tp_fg [pref get gdb/src/trace_fg]
if {[pref get gdb/control_target]} {
addPopup break_rgn "Continue to Here" "$this continue_to_here" \
[pref get gdb/src/PC_TAG] 0 0
addPopup break_rgn "Jump to Here" "$this jump_to_here" \
[pref get gdb/src/PC_TAG] 0 0
$popups(break_rgn) add separator
addPopup break_rgn "Set Breakpoint" "$this set_bp_at_line" $bp_fg
lappend popups(break_rgn-browse) 1
lappend popups(break_rgn-control) 1
addPopup break_rgn "Set Temporary Breakpoint" "$this set_bp_at_line T" \
[pref get gdb/src/temp_bp_fg]
addPopup break_rgn "Set Breakpoint on Thread(s)..." \
"$this ask_thread_bp" [pref get gdb/src/thread_fg] 0 0
}
if {$Tracing} {
$popups(break_rgn) add separator
addPopup break_rgn "Set Tracepoint" "$this set_tp_at_line" $tp_fg
}
}
if {![winfo exists $popups(bp)]} {
# this popup is used when the line contains a set breakpoint
menu $popups(bp) -tearoff 0
if {!$Browsing && [pref get gdb/control_target]} {
addPopup bp "Continue to Here" "$this continue_to_here" {} 0 0
addPopup bp "Jump to Here" "$this jump_to_here" {} 0 0
$popups(bp) add separator
addPopup bp "Disable Breakpoint" "$this enable_disable_at_line disable" \
$bp_fg
$popups(bp) add separator
}
addPopup bp "Delete Breakpoint" "$this remove_bp_at_line"
# Currently you cannot set a tracepoint and a breakpoint at the same line...
#
# if {$Tracing} {
# addPopup bp "Set Tracepoint" "$this set_tp_at_line" $tp_fg
# }
}
if {![winfo exists $popups(tp)]} {
# This is the popup to use when the line contains a set tracepoint
menu $popups(tp) -tearoff 0
if {[pref get gdb/control_target]} {
addPopup tp "Continue to Here" "$this continue_to_here" green 0 0
addPopup tp "Jump to Here" "$this jump_to_here" {} 0 0
# $popups(tp) add separator
# Currently you cannot set a tracepoint and a breakpoint at the same line...
#
# addPopup tp "Set Breakpoint" "$this set_bp_at_line" $bp_fg
# addPopup tp "Set Temporary Breakpoint" "$this set_bp_at_line T" \
# [pref get gdb/src/temp_bp_fg]
# addPopup tp "Set Breakpoint on Thread(s)..." \
# "$this ask_thread_bp" \
# [pref get gdb/src/thread_fg] 0 0
}
if {$Tracing} {
$popups(tp) add separator
addPopup tp "Modify Tracepoint" "$this set_tp_at_line" $tp_fg
addPopup tp "Delete Tracepoint" "$this remove_tp_at_line" $tp_fg
}
}
# This is not currently used, since you can't set a bp & a tp on the same line.
# N.B. however, we don't exclude this on the command line, but...
if {![winfo exists $popups(bp_and_tp)]} {
# this popup is used when the line contains a set breakpoint & tracepoint
menu $popups(bp_and_tp) -tearoff 0
if {!$Browsing && [pref get gdb/control_target]} {
addPopup bp_and_tp "Continue to Here" "$this continue_to_here" \
green 0 0
addPopup bp_and_tp "Jump to Here" "$this jump_to_here" \
green 0 0
$popups(bp_and_tp) add separator
}
addPopup bp_and_tp "Delete Breakpoint" "$this remove_bp_at_line" $bp_fg
if {$Tracing} {
addPopup bp_and_tp "Modify Tracepoint" "$this set_tp_at_line" $tp_fg
addPopup bp_and_tp "Delete Tracepoint" \
"$this remove_tp_at_line" $tp_fg
}
}
if {![winfo exists $popups(disabled_bp)]} {
menu $popups(disabled_bp) -tearoff 0
addPopup disabled_bp "Enable Breakpoint" \
"$this enable_disable_at_line enable" $bp_fg
$popups(disabled_bp) add separator
addPopup disabled_bp "Delete Breakpoint" "$this remove_bp_at_line"
}
if {![winfo exists $popups(tp_browse)]} {
# this popup is on a tracepoint when browsing.
menu $popups(tp_browse) -tearoff 0
addPopup tp_browse "Next hit Here" "$this next_hit_at_line" \
green
}
}
# ------------------------------------------------------------------
# METHOD: build_win - build the main source paned window
# ------------------------------------------------------------------
itcl::body SrcTextWin::build_win {} {
cyg::panedwindow $itk_interior.p
set _tpane pane$filenum
incr filenum
$itk_interior.p add $_tpane
set pane1 [$itk_interior.p childsite $_tpane]
set Stwc(gdbtk_scratch_widget:pane) $_tpane
set Stwc(gdbtk_scratch_widget:dirty) 0
set twinp [iwidgets::scrolledtext $pane1.st \
-hscrollmode dynamic -vscrollmode dynamic]
set twin [$twinp component text]
pack $twinp -fill both -expand yes
pack $itk_interior.p -fill both -expand yes
config_win $twin
}
# ------------------------------------------------------------------
# METHOD: SetRunningState - set state based on if GDB is running or not.
# This disables the popup menus when GDB is not running yet.
# ------------------------------------------------------------------
itcl::body SrcTextWin::SetRunningState {state} {
# debug "$state"
foreach elem $popups(run_disabled) {
$popups([lindex $elem 0]) entryconfigure [lindex $elem 1] -state $state
}
}
# ------------------------------------------------------------------
# METHOD: enable - enable or disable bindings and change cursor
# ------------------------------------------------------------------
itcl::body SrcTextWin::enable {on} {
if {$on} {
set Running 0
set glyph ""
set bnd ""
set status normal
} else {
set Running 1
set glyph watch
set bnd "break"
set status disabled
}
if {[winfo exists $twin]} {
bind $twin <B1-Motion> $bnd
bind $twin <Double-1> $bnd
bind $twin <Triple-1> $bnd
enable_disable_src_tags $twin $status
$twin configure -cursor $glyph
}
if {$bwin != ""} {
bind $bwin <B1-Motion> $bnd
bind $bwin <Double-1> $bnd
bind $bwin <Triple-1> $bnd
enable_disable_src_tags $bwin $status
$bwin configure -cursor $glyph
}
}
# ------------------------------------------------------------------
# PROC: makeBreakDot - make the break dot for the screen
# ------------------------------------------------------------------
itcl::body SrcTextWin::makeBreakDot {size colorList {image {}}} {
if {$size > 32} {
set size 32
} elseif {$size < 1} {
set size 1
}
if {$image == ""} {
set image [image create photo -width $size -height $size]
} else {
$image blank
$image configure -width $size -height $size
}
if {[llength $colorList] == 1} {
set x1 1
set x2 [expr {1 + $size}]
set y1 1
set y2 $x2
$image put $colorList -to 1 1 $x2 $y2
} else {
set x1 1
set x3 [expr {1 + $size}]
set x2 [expr int((1 + $size)/2)]
set y1 1
set y2 $x3
$image put [lindex $colorList 0] -to 1 1 $x2 $y2
$image put [lindex $colorList 1] -to [expr $x2 + 1] 1 $x3 $y2
}
return $image
}
# ------------------------------------------------------------------
# METHOD: setTabs - set the tabs for the assembly/src windows
# ------------------------------------------------------------------
itcl::body SrcTextWin::setTabs {win {asm S}} {
set fsize [font measure [pref get gdb/src/font] "W"]
set tsize [pref get gdb/src/tab_size]
set rest ""
if {[string compare $asm "S"] != 0} {
set first [expr {$fsize * 12}]
set second [expr {$fsize * 13}]
set third [expr {$fsize * 34}]
for {set i 1} {$i < 8} {incr i} {
lappend rest [expr {(34 + ($i * $tsize)) * $fsize}] left
}
set tablist [concat [list $first right $second left $third left] $rest]
} else {
# SOURCE window
# The first tab right-justifies the line numbers and the second
# tab is the left margin for the start on the source code. The remaining
# tabs should be regularly spaced depending on prefs.
if {$Linenums} {
set first [expr {$fsize * 6}] ;# "- " plus 4 digit line number
set second [expr {$fsize * 7}] ;# plus a space after the number
for {set i 1} {$i < 8} {incr i} {
lappend rest [expr {(7 + ($i * $tsize)) * $fsize}] left
}
set tablist [concat [list $first right $second left] $rest]
} else {
set first [expr {$fsize * 2}]
for {set i 1} {$i < 8} {incr i} {
lappend rest [expr {(2 + ($i * $tsize)) * $fsize}] left
}
set tablist [concat [list $first left] $rest]
}
}
$win configure -tabs $tablist
}
itcl::body SrcTextWin::enable_disable_src_tags {win how} {
switch $how {
normal {
set cur1 dot
set cur2 xterm
}
disabled {
set cur1 watch
set cur2 $cur1
}
browse {
set cur1 dot
set cur2 xterm
}
}
if {[string compare $how browse] == 0} {
$win tag bind break_rgn_tag <Enter> { }
$win tag bind break_rgn_tag <Leave> { }
foreach type $bp_types {
$win tag bind ${type}_tag <Enter> { }
$win tag bind ${type}_tag <Motion> { }
$win tag bind ${type}_tag <Leave> { }
}
} else {
$win tag bind break_rgn_tag <Enter> "$win config -cursor $cur1"
$win tag bind break_rgn_tag <Leave> "$win config -cursor $cur2"
foreach type $bp_types {
$win tag bind ${type}_tag <Enter> "$win config -cursor $cur1"
$win tag bind ${type}_tag <Motion> "$this motion bp %W %x %y"
$win tag bind ${type}_tag <Leave> \
"$this cancelMotion;$win config -cursor $cur2"
}
}
$win tag bind tp_tag <Enter> "$win config -cursor $cur1"
$win tag bind tp_tag <Motion> "$this motion bp %W %x %y"
$win tag bind tp_tag <Leave> "$this cancelMotion;$win config -cursor $cur2"
}
# ------------------------------------------------------------------
# METHOD: config_win - configure the source or assembly text window
# ------------------------------------------------------------------
itcl::body SrcTextWin::config_win {win {asm S}} {
# debug "$win $asm Tracing=$Tracing Browsing=$Browsing"
$win config -borderwidth 2 -insertwidth 0 -wrap none
# font
set font [pref get gdb/src/font]
$win configure -font $font -bg $::Colors(textbg) -fg $::Colors(textfg)
setTabs $win $asm
# set up some tags. should probably be done differently
# !! change bg?
$win tag configure break_rgn_tag
foreach type $bp_types {
$win tag configure ${type}_tag
}
$win tag configure tp_tag
$win tag configure source_tag2 -foreground [pref get gdb/src/source2_fg]
$win tag configure PC_TAG -background [pref get gdb/src/PC_TAG]
$win tag configure STACK_TAG -background [pref get gdb/src/STACK_TAG]
$win tag configure BROWSE_TAG -background [pref get gdb/src/BROWSE_TAG]
# search tag used to highlight searches
foreach option [$win tag configure sel] {
set op [lindex $option 0]
set val [lindex $option 4]
eval $win tag configure search $op $val
}
# bind mouse button 3 to the popup men
$win tag bind source_tag <Button-3> "$this do_source_popup %X %Y %x %y"
$win tag bind source_tag2 <Button-3> "$this do_source_popup %X %Y %x %y"
# bind mouse button 3 to the popup menus
if {!$Browsing} {
$win tag bind break_rgn_tag <Button-3> \
"$this do_tag_popup break_rgn %X %Y %y; break"
foreach type $bp_types {
if {$type == "disabled_bp"} then {
set tag disabled_bp
} else {
set tag bp
}
$win tag bind ${type}_tag <Button-3> \
"$this do_tag_popup $tag %X %Y %y; break"
}
$win tag bind tp_tag <Button-3> "$this do_tag_popup tp %X %Y %y; break"
$win tag bind bp_and_tp_tag <Button-3> "$this do_tag_popup bp_and_tp %X %Y %y; break"
} else {
$win tag bind tp_tag <Button-3> "$this do_tag_popup tp_browse %X %Y %y; break"
$win tag bind break_rgn_tag <Button-3> { }
foreach type $bp_types {
$win tag bind ${type}_tag <Button-3> { }
}
$win tag bind bp_and_tp_tag <Button-3> "$this do_tag_popup tp_browse %X %Y %y; break"
}
# Disable printing and cut and paste keys; makes the window readonly
# We do this so we don't have to enable and disable the
# text widget everytime we want to modify it.
bind $win <Key> {if {"%A" != "{}"} {break}}
bind $win <Delete> break
bind $win <ButtonRelease-2> {break}
# GDB key bindings
# We need to explicitly ignore keys with the Alt modifier, since
# otherwise they will interfere with selecting menus on Windows.
if {!$Browsing && [pref get gdb/control_target]} {
bind_plain_key $win c "$this do_key continue; break"
bind_plain_key $win r "$this do_key run; break"
bind_plain_key $win f "$this do_key finish; break"
} else {
bind_plain_key $win n "$this do_key tfind_next; break"
bind_plain_key $win p "$this do_key tfind_prev; break"
bind_plain_key $win f "$this do_key tfind_start; break"
bind_plain_key $win l "$this do_key tfind_line; break"
bind_plain_key $win h "$this do_key tfind_tp; break"
}
bind_plain_key $win u "$this do_key up; break"
bind_plain_key $win d "$this do_key down; break"
bind_plain_key $win x "$this do_key quit; break"
if {!$Browsing && [pref get gdb/control_target]} {
if {[string compare $asm "S"] != 0} {
bind_plain_key $win s "$this do_key stepi; break"
bind_plain_key $win n "$this do_key nexti; break"
} else {
bind_plain_key $win s "$this do_key step; break"
bind_plain_key $win n "$this do_key next; break"
}
}
bind_plain_key $win Control-h "$this do_key thread_list; break"
bind_plain_key $win Control-f "$this do_key browser; break"
bind_plain_key $win Control-d "$this do_key download; break"
bind_plain_key $win Control-p "$this do_key print"
bind_plain_key $win Control-u "$this do_key debug; break"
bind_plain_key $win Control-o [list $this do_key open]
bind_plain_key $win Control-a [list $this do_key attach]
bind_plain_key $win Control-w [code $this do_key close]
if {!$Browsing && [pref get gdb/control_target]} {
# Ctrl+F5 is another accelerator for Run
bind_plain_key $win Control-F5 "$this do_key run"
}
bind_plain_key $win Control-F11 "$this do_key debug"
bind_plain_key $win Alt-v "$win yview scroll -1 pages"
bind_plain_key $win Control-v [format {
%s yview scroll 1 pages
break
} $win]
# bind mouse button 1 to the breakpoint method or tracepoint,
# depending on the settings of the B1_behavior setting. We don't
# have to bind to bp_and_tp because that will fall through to either
# the tp or the bp tag. We have to put in the break so that we don't
# both remove & reinsert a BP when we have both a tp & a bp on the same line.
# If we are browsing, then disable Button-1
if {!$Browsing} {
if {[pref get gdb/B1_behavior]} {
$win tag bind break_rgn_tag <Button-1> "$this set_bp_at_line N $win %y; break"
foreach type $bp_types {
$win tag bind ${type}_tag <Button-1> "$this remove_bp_at_line $win %y; break"
}
$win tag bind tp_tag <Button-1> "$this set_bp_at_line N $win %y; break"
} else {
$win tag bind break_rgn_tag <Button-1> "$this set_tp_at_line $win %y; break"
foreach type $bp_types {
$win tag bind ${type}_tag <Button-1> "$this set_tp_at_line $win %y; break"
}
$win tag bind tp_tag <Button-1> "$this set_tp_at_line $win %y; break"
}
} else {
$win tag bind break_rgn_tag <Button-1> { }
foreach type $bp_types {
$win tag bind ${type}_tag <Button-1> { }
}
$win tag bind tp_tag <Button-1> { }
}
# avoid special handling of double and triple clicks in break area
bind $win <Double-1> [format {
if {[lsearch [%s tag names @%%x,%%y] break_rgn_tag] >= 0} {
break
}
} $win $win]
bind $win <Triple-1> [format {
if {[lsearch [%s tag names @%%x,%%y] break_rgn_tag] >= 0} {
break
}
} $win $win]
# bind window shortcuts
bind_plain_key $win Control-s "$this do_key stack"
bind_plain_key $win Control-r "$this do_key registers"
bind_plain_key $win Control-m "$this do_key memory"
bind_plain_key $win Control-t "$this do_key watch"
bind_plain_key $win Control-l "$this do_key locals"
bind_plain_key $win Control-k "$this do_key kod"
if { !$Tracing } {
bind_plain_key $win Control-b "$this do_key breakpoints"
} else {
bind_plain_key $win Control-t "$this do_key tracepoints"
bind_plain_key $win Control-u "$this do_key tdump"
}
bind_plain_key $win Control-n "$this do_key console"
if {$Browsing} {
enable_disable_src_tags $win browse
} else {
enable_disable_src_tags $win normal
}
if {$UseVariableBalloons} {
$win tag bind source_tag <Motion> "$this motion var %W %x %y"
$win tag bind source_tag <Leave> "$this cancelMotion"
}
# Up/Down arrow key bindings
bind_plain_key $win Up [list %W yview scroll -1 units]
bind_plain_key $win Down [list %W yview scroll +1 units]
# After loading a new file, focus sometimes gets lost
# so point it back to this window if it doesn't already
# point elsewhere.
if {[focus -displayof $win] == ""} {focus $win}
}
# ------------------------------------------------------------------
# METHOD: addPopup - adds a popup to one of the source popup menus
# ------------------------------------------------------------------
itcl::body SrcTextWin::addPopup {menu label command {abg {}} {browse 1} {run 1}} {
if {$abg == ""} {
$popups($menu) add command -label $label -command $command
} else {
$popups($menu) add command -label $label -command $command \
-activebackground $abg
}
set index [$popups($menu) index last]
if {!$run} {
lappend popups(run_disabled) [list $menu $index]
}
if {!$browse} {
lappend popups(browse_disabled) [list $menu $index]
}
}
# ------------------------------------------------------------------
# PUBLIC METHOD: set_variable - Handle changes in the gdb variables
# changed through the "set" gdb command.
# ------------------------------------------------------------------
itcl::body SrcTextWin::set_variable {event} {
set var [$event get variable]
set val [$event get value]
debug "Set hook got called with $var $val"
switch $var {
disassembly-flavor {
disassembly_changed
}
}
}
# ------------------------------------------------------------------
# METHOD: disassembly_changed - The disassembly flavor has changed,
# mark all the cached assembly windows dirty, and force the
# visible window to be redisplayed.
# ------------------------------------------------------------------
itcl::body SrcTextWin::disassembly_changed {} {
foreach name [array names Stwc *:pane] {
debug "Looking at $name"
set vals [split $name ,]
if {([string compare [lindex $vals 1] "A"] == 0)
|| ([string compare [lindex $vals 1] "M"] == 0)} {
debug "Setting $name to dirty"
set Stwc([lindex $vals 0]:dirty) 1
}
}
if {[string compare $current(mode) "SOURCE"] != 0} {
location $current(tag) $current(filename) $current(funcname) $current(line) \
$current(addr) $pc(addr) $current(lib)
}
}
# ------------------------------------------------------------------
# METHOD: reconfig - used when preferences change
# ------------------------------------------------------------------
itcl::body SrcTextWin::reconfig {} {
# debug
# Make sure we redo the break images when we reconfigure
set size [font measure [pref get gdb/src/font] "W"]
makeBreakDot $size [pref get gdb/src/bp_fg] $break_images(bp)
makeBreakDot $size [pref get gdb/src/temp_bp_fg] $break_images(temp_bp)
makeBreakDot $size [pref get gdb/src/disabled_fg] $break_images(disabled_bp)
makeBreakDot $size [pref get gdb/src/trace_fg] $break_images(tp)
makeBreakDot $size \
[list [pref get gdb/src/trace_fg] [pref get gdb/src/bp_fg]] \
$break_images(bp_and_tp)
makeBreakDot $size [pref get gdb/src/thread_fg] $break_images(thread_bp)
# Tags
$twin tag configure PC_TAG -background [pref get gdb/src/PC_TAG]
$twin tag configure STACK_TAG -background [pref get gdb/src/STACK_TAG]
$twin tag configure BROWSE_TAG -background [pref get gdb/src/BROWSE_TAG]
switch $current(mode) {
SOURCE {
setTabs $twin
}
SRC+ASM {
setTabs $twin
setTabs $bwin A
}
default {
setTabs $twin A
}
}
# Variable Balloons
if {$ignore_var_balloons} {
set balloons 0
} else {
set balloons [pref get gdb/src/variableBalloons]
}
if {$UseVariableBalloons != $balloons} {
set UseVariableBalloons $balloons
if {$UseVariableBalloons} {
$twin tag bind source_tag <Motion> "$this motion var %W %x %y"
$twin tag bind source_tag <Leave> "$this cancelMotion"
add_hook gdb_idle_hook [list $this updateBalloon]
} else {
cancelMotion
$twin tag bind source_tag <Motion> {}
$twin tag bind source_tag <Leave> {}
$twin tag remove _show_variable 1.0 end
remove_hook gdb_idle_hook [list $this updateBalloon]
}
}
# Tracing Hooks
catch {remove_hook control_mode_hook "$this set_control_mode"}
catch {remove_hook gdb_trace_find_hook "$this trace_find_hook"}
if {$Tracing} {
add_hook control_mode_hook "$this set_control_mode"
add_hook gdb_trace_find_hook "$this trace_find_hook"
}
# Popup colors
# need to rewrite because of the new addPopup function
# if {$Tracing} {
# $twin.bmenu entryconfigure 0 -activebackground [pref get gdb/src/trace_fg]
# } else {
# $twin.bmenu entryconfigure 0 -activebackground [pref get gdb/src/PC_TAG]
# $twin.bmenu entryconfigure 1 -activebackground [pref get gdb/src/bp_fg]
# $twin.bmenu entryconfigure 2 -activebackground \
# [pref get gdb/src/temp_bp_fg]
# $twin.bmenu entryconfigure 3 -activebackground \
# [pref get gdb/src/thread_fg]
# }
}
# ------------------------------------------------------------------
# METHOD: updateBalloon - we have gone idle, update the balloon
# ------------------------------------------------------------------
itcl::body SrcTextWin::updateBalloon {} {
set err [catch {$_balloon_var update} changed]
catch {$_balloon_var name} var
if {!$err} {
if {$changed != ""} {
# The variable's value has changed, so update the
# balloon with its new value
balloon register $twin "$var=[balloon_value $_balloon_var]" _show_variable
}
}
}
itcl::body SrcTextWin::balloon_value {variable} {
catch {$variable value} value
set value [string trim $value \ \r\t\n]
# Insert the variable's type for things like ptrs, etc.
catch {$variable type} type
if {$value == "{...}"} {
set val "$type $value"
} elseif {[regexp -- {0x([0-9a-fA-F]+) <[a-zA-Z_].*} $value str]} {
set val $str
} elseif {[string first * $type] != -1} {
set val "($type) $value"
} elseif {[string first \[ $type] != -1} {
set val "$type"
} else {
set val "$value"
}
return $val
}
# ------------------------------------------------------------------
# METHOD: ClearTags - clear all tags
# ------------------------------------------------------------------
itcl::body SrcTextWin::ClearTags {} {
foreach tag {PC_TAG BROWSE_TAG STACK_TAG} {
catch {
$twin tag remove $tag $current(line).2 $current(line).end
$twin tag remove $tag $pc(line).2 $pc(line).end
$twin tag remove $tag $current(asm_line).2 $current(asm_line).end
if {$bwin != ""} {
$bwin tag remove $tag $current(asm_line).2 $current(asm_line).end
}
}
}
}
# ------------------------------------------------------------------
# METHOD: _mtime_changed - check if the modtime for a file
# has changed.
# ------------------------------------------------------------------
itcl::body SrcTextWin::_mtime_changed {filename} {
global tcl_platform
if [catch {gdb_find_file $filename} f] {
set r 1
} elseif {$f == ""} {
set r 1
} else {
if {[string compare $tcl_platform(platform) "windows"] == 0} {
set f [ide_cygwin_path to_win32 $f]
}
if {[catch {file mtime $f} mtime]} {
debug "Could not stat file \"$f\" - \"$mtime\""
# The return code is not of much significance in this case
return 1
}
if {![info exists Stwc($filename:mtime)]} {
debug "no mtime. resetting to zero"
set Stwc($filename:mtime) 0
}
# debug "Stwc($filename:mtime)=$Stwc($filename:mtime); mtime=$mtime"
if {$mtime == $Stwc($filename:mtime)} {
set r 0
} else {
set r 1
set Stwc($filename:mtime) $mtime
set Stwc($filename:dirty) 1
}
}
return $r
}
# ------------------------------------------------------------------
# METHOD: FillSource - fill a window with source
# ------------------------------------------------------------------
itcl::body SrcTextWin::FillSource {w tagname filename funcname line addr pc_addr lib} {
global gdb_running
upvar ${w}win win
# debug "$gdb_running $tagname line=$line pc(line)=$pc(line)"
# debug "current(filename)=$current(filename) filename=$filename"
if {$filename != ""} {
# load new file if necessary
set mtime [_mtime_changed $filename]
if {[string compare $filename $current(filename)] != 0 \
|| $mode_changed || $mtime} {
if {![LoadFile $w $filename $lib $mtime]} {
# failed to find source file
dbug W "Changing to ASSEMBLY"
# We have to update this data here (it is also done by the caller)
# because we want to call mode, which calls mode_set, which calls
# location using these values.
set current(line) $line
set current(tag) $tagname
set current(addr) $addr
set current(funcname) $funcname
set current(filename) $filename
set current(lib) $lib
set oldmode SOURCE
$parent mode "" ASSEMBLY
return
}
if {$current(mode) != "SRC+ASM"} {
# reset this flag in FillAssembly for SRC+ASM mode
set mode_changed 0
}
}
# debug "cf=$current(filename) pc=$pc(filename) filename=$filename"
if {$current(filename) != ""} {
if {$gdb_running && $pc(filename) == $filename} {
# set the PC tag in this file
$win tag add PC_TAG $pc(line).2 $pc(line).end
}
if {$tagname != "PC_TAG"} {
if {$gdb_running && ($pc(filename) == $filename) \
&& ($pc(line) == $line)} {
# if the tag is on the same line as the PC, set a PC tag
$win tag add PC_TAG $line.2 $line.end
} else {
$win tag add $tagname $line.2 $line.end
}
}
if {$pc(filename) == $filename && $line == 0} {
# no line specified, so show line with PC
display_line $win $pc(line)
} else {
display_line $win $line
}
}
return
}
# no source; switch to assembly
dbug W "no source file; switch to assembly"
# We have to update this data here (it is also done by the caller)
# because we want to call mode, which calls mode_set, which calls
# location using these values.
set current(line) $line
set current(tag) $tagname
set current(addr) $addr
set current(funcname) $funcname
set current(filename) $filename
set current(lib) $lib
set oldmode $current(mode)
$parent mode "" ASSEMBLY
}
# ------------------------------------------------------------------
# METHOD: FillAssembly - fill a window with disassembled code
# ------------------------------------------------------------------
itcl::body SrcTextWin::FillAssembly {w tagname filename funcname line addr pc_addr lib} {
global gdb_running
upvar ${w}win win
upvar _${w}pane pane
# debug "$win $tagname $filename $funcname $line $addr $pc_addr"
# debug "mode_changed=$mode_changed"
# debug "funcname=$funcname"
# debug "current(funcname)=$current(funcname)"
if {$funcname == ""} {
set oldpane $pane
set pane $Stwc(gdbtk_scratch_widget:pane)
set win [[$itk_interior.p childsite $pane].st component text]
$win delete 0.0 end
$win insert 0.0 "Select function name to disassemble"
if {$oldpane != "" && $oldpane != $pane} {
$itk_interior.p replace $oldpane $pane
} else {
$itk_interior.p show $pane
}
return
} elseif {$funcname != $current(funcname) || $mode_changed
|| ([info exists Stwc($addr:dirty)] && $Stwc($addr:dirty))} {
set mode_changed 0
set oldpane $pane
set result [LoadFromCache $w $addr A $lib]
if {$result == 1} {
#debug "Disassembling at $addr"
#debug "cf=$current(filename) name=$filename"
if {[catch {gdb_load_disassembly $win nosource \
[scope _map] $Cname $addr} mess]} {
# print some intelligent error message?
dbug E "Disassemble failed: $mess"
UnLoadFromCache $w $oldpane $addr A $lib
set pane $Stwc(gdbtk_scratch_widget:pane)
set win [[$itk_interior.p childsite $pane].st component text]
$win delete 0.0 end
$win insert 0.0 "$mess"
if {$oldpane != "" && $oldpane != $pane} {
$itk_interior.p replace $oldpane $pane
} else {
$itk_interior.p show $pane
}
} else {
debug "address range is $mess"
}
} elseif {$result == 0} {
debug "LoadFromCache returned 0"
} else {
# This branch should not ever happen. In assembly mode, there
# are no checks in LoadFromCache that can fail.
debug "LoadFromCache returned -1"
}
set current(filename) $filename
set do_display_breaks 1
}
# highlight proper line number
_highlightAsmLine $win $addr $pc_addr $tagname $filename $funcname
display_line $win $current(asm_line)
}
# ------------------------------------------------------------------
# METHOD: FillMixed - fill a window with mixed source and assembly
# ------------------------------------------------------------------
itcl::body SrcTextWin::FillMixed {w tagname filename funcname line addr pc_addr lib} {
global gdb_running
upvar ${w}win win
upvar _${w}pane pane
# debug "$win $tagname $filename $funcname $line $addr $pc_addr"
if {$funcname == ""} {
set oldpane $pane
set pane $Stwc(gdbtk_scratch_widget:pane)
set win [[$itk_interior.p childsite $pane].st component text]
$win delete 0.0 end
$win insert 0.0 "Select function name to disassemble"
if {$oldpane != ""} {
$itk_interior.p replace $oldpane $pane
} else {
$itk_interior.p show $pane
}
} elseif {$funcname != $current(funcname) || $mode_changed
|| ([info exists Stwc($funcname:dirty)] && $Stwc($funcname:dirty))} {
set mode_changed 0
set oldpane $pane
if {[LoadFromCache $w $funcname M $lib]} {
# debug "Disassembling at $addr"
if {[catch {gdb_load_disassembly $win source \
[scope _map] $Cname $addr} mess] } {
# print some intelligent error message
dbug W "Disassemble Failed: $mess"
UnLoadFromCache $w $oldpane $funcname M $lib
set current(line) $line
set current(tag) $tagname
set current(addr) $addr
set current(funcname) $funcname
set current(filename) $filename
set current(lib) $lib
set oldmode MIXED
$parent mode "" ASSEMBLY
return
} else {
debug "address range is $mess"
}
}
set current(filename) $filename
# now set the breakpoints
set do_display_breaks 1
}
# highlight proper line number
_highlightAsmLine $win $addr $pc_addr $tagname $filename $funcname
display_line $win $current(asm_line)
}
# ------------------------------------------------------------------
# METHOD: _highlightAsmLine - highlight the current execution line
# in one of the assembly modes
# ------------------------------------------------------------------
itcl::body SrcTextWin::_highlightAsmLine {win addr pc_addr \
tagname filename funcname} {
global gdb_running
# Some architectures allow multiple instructions in each asm source
# line...
if {[info exists _map($Cname,pc=$addr)]} {
set current(asm_line) $_map($Cname,pc=$addr)
} else {
set x [gdb_incr_addr $current(addr) -2]
if {[info exists _map($Cname,pc=$x)]} {
set current(asm_line) $_map($Cname,pc=$x)
}
}
# if current file has PC, highlight that too
if {$gdb_running && $tagname != "PC_TAG" && $pc(filename) == $filename
&& $pc(func) == $funcname} {
set pc(asm_line) $_map($Cname,pc=$pc_addr)
$win tag add PC_TAG $pc(asm_line).2 $pc(asm_line).end
}
# don't set browse tag if it is at PC
if {$pc_addr != $addr || $tagname == "PC_TAG"} {
# HACK. In STACK mode we usually want the previous instruction
# but not when we are browsing a trace experiment.
if {[string compare $tagname "STACK_TAG"] == 0 && !$Browsing} {
incr current(asm_line) -1
}
$win tag add $tagname $current(asm_line).2 $current(asm_line).end
}
}
# ------------------------------------------------------------------
# METHOD: set_tag - update tag to STACK without making other changes
# ------------------------------------------------------------------
itcl::body SrcTextWin::set_tag_to_stack {} {
foreach window [list $twin $bwin] {
if {$window == ""} then {
continue
}
foreach {start end} [$window tag ranges PC_TAG] {
$window tag remove PC_TAG $start $end
$window tag add STACK_TAG $start $end
}
}
set current(tag) STACK_TAG
}
# ------------------------------------------------------------------
# METHOD: location - display a location in a file
# ------------------------------------------------------------------
itcl::body SrcTextWin::location {tagname filename funcname line addr pc_addr lib} {
# debug "$tagname $filename $line $addr $pc_addr, mode=$current(mode) oldmode=$oldmode cf=$current(filename) lib=$lib"
ClearTags
# It seems odd to do this as a string compare, but on the Alpha,
# where ints are 32 bit but addresses are 64, a numerical compare
# will overflow Tcl's ints.
if {$tagname == "PC_TAG" && [string compare $addr $pc_addr] == 0} {
set pc(filename) $filename
set pc(line) $line
set pc(addr) $addr
set pc(func) $funcname
set pc(lib) $lib
}
if {$oldmode != "" \
&& [string compare $filename $current(filename)] != 0} {
if [catch {gdb_find_file $filename} fullname] {
dbug W "$filename: $fullname"
set fullname ""
}
if {$fullname != ""} {
set tmp $oldmode
set oldmode ""
$parent mode "" $tmp 0
}
}
set oldpane $_tpane
switch $current(mode) {
SOURCE {
FillSource t $tagname $filename $funcname $line $addr $pc_addr $lib
}
ASSEMBLY {
FillAssembly t $tagname $filename $funcname $line $addr $pc_addr $lib
}
MIXED {
FillMixed t $tagname $filename $funcname $line $addr $pc_addr $lib
}
SRC+ASM {
FillSource t $tagname $filename $funcname $line $addr $pc_addr $lib
# This may seem redundant, but it is NOT. FillSource can change
# the mode from SOURCE to ASSEMBLY if sources were not found. If
# this happens, then MIXED mode is pointless, so forget the bottom
# pane.
if {$current(mode) == "SRC+ASM"} {
FillAssembly b $tagname $filename $funcname $line $addr $pc_addr $lib
}
}
}
# After switching panes, clear the previous pane's cursor so that it isn't
# used as the default when no other cursors are set.
if { "$oldpane" != "$_tpane" } {
$twin configure -cursor ""
}
set current(line) $line
set current(tag) $tagname
set current(addr) $addr
set current(funcname) $funcname
set current(filename) $filename
set current(lib) $lib
if {$do_display_breaks} {
display_breaks
set do_display_breaks 0
}
}
# ------------------------------------------------------------------
# METHOD: LoadFile - loads in a new source file
# ------------------------------------------------------------------
itcl::body SrcTextWin::LoadFile {w name lib mtime_changed} {
debug "$name $current(filename) $current(mode)"
upvar ${w}win win
upvar _${w}pane pane
set oldpane $pane
set result [LoadFromCache $w $name "S" $lib]
if {$result == -1} {
# This is a source file we could not find the source for...
return 0
} elseif {$result == 1 || $mtime_changed} {
$win delete 0.0 end
debug "READING $name"
if {[catch {gdb_loadfile $win $name $Linenums} msg]} {
dbug W "Error opening $name: $msg"
#if {$msg != ""} {
# tk_messageBox -icon error -title "GDB" -type ok \
# -modal task -message $msg
#}
UnLoadFromCache $w $oldpane $name "" $lib
return 0
}
}
set current(filename) $name
# Display all breaks/traces
set do_display_breaks 1
return 1
}
# ------------------------------------------------------------------
# METHOD: display_line - make sure a line is displayed and near the center
# ------------------------------------------------------------------
itcl::body SrcTextWin::display_line { win line } {
::update idletasks
# keep line near center of display
set pixHeight [winfo height $win]
set topLine [lindex [split [$win index @0,0] .] 0]
set botLine [lindex [split [$win index @0,${pixHeight}] .] 0]
set margin [expr {int(0.2*($botLine - $topLine))}]
if {$line < [expr {$topLine + $margin}]} {
set num [expr {($topLine - $botLine) / 2}]
} elseif {$line > [expr {$botLine - $margin}]} {
set num [expr {($botLine - $topLine) / 2}]
} else {
set num 0
}
$win yview scroll $num units
$win see $line.0
}
# ------------------------------------------------------------------
# METHOD: display_breaks - insert all breakpoints and tracepoints
# uses current(filename) in SOURCE mode
# ------------------------------------------------------------------
itcl::body SrcTextWin::display_breaks {} {
# debug
# clear any previous breakpoints
foreach type "$bp_types tp" {
foreach {start stop} [$twin tag ranges ${type}_tag] {
scan $start "%d." linenum
removeBreakTag $twin $linenum ${type}_tag
}
}
# now do second pane if it exists
if {[info exists bwin]} {
foreach type "$bp_types tp" {
foreach {start stop} [$twin tag ranges ${type}_tag] {
scan $start "%d." linenum
removeBreakTag $twin $linenum ${type}_tag
}
}
}
# Display any existing breakpoints.
foreach bpnum [gdb_get_breakpoint_list] {
set info [gdb_get_breakpoint_info $bpnum]
set addr [lindex $info 3]
set line [lindex $info 2]
set file [lindex $info 0]
set type [lindex $info 6]
set enabled [lindex $info 5]
bp create $bpnum $addr $line $file $type $enabled
}
# Display any existing tracepoints.
foreach bpnum [gdb_get_tracepoint_list] {
set info [gdb_get_tracepoint_info $bpnum]
set addr [lindex $info 3]
set line [lindex $info 2]
set file [lindex $info 0]
bp create $bpnum $addr $line $file tracepoint
}
}
# ------------------------------------------------------------------
# METHOD: insertBreakTag - insert the right amount of tag chars
# into the text window WIN, at line linenum.
# ------------------------------------------------------------------
itcl::body SrcTextWin::insertBreakTag {win linenum tag} {
# debug "$win $linenum $tag"
# Get the tags at the current line.
# If there is a "break_rgn_tag", then there are currently no other
# break/trace points at this line. So replace the break_rgn_tag
# with this tag. Otherwise, add the new tag, and then the joint
# tag. We will query the length of the previous tag, so we don't have
# to hard code it here.
set tag_list [$win tag names $linenum.0]
set img_name [string range $tag 0 [expr [string length $tag] - 5]]
if {[lsearch $tag_list break_rgn_tag] != -1} {
set stop [lindex [$win tag nextrange break_rgn_tag \
$linenum.0 "$linenum.0 lineend"] 1]
$win tag remove break_rgn_tag $linenum.0 "$linenum.0 lineend"
$win delete $linenum.0
# Strip the "_tag" off the end of the tag to get the image name.
$win image create $linenum.0 -image $break_images($img_name)
$win tag add $tag $linenum.0 $stop
} else {
set other_tag [lindex $tag_list \
[lsearch -glob $tag_list {*[bt]p_tag}]]
if {$other_tag == ""} {
set stop 4
} else {
set stop [lindex [$win tag nextrange $other_tag \
$linenum.0 "$linenum.0 lineend"] 1]
}
$win tag add $tag $linenum.0 $stop
$win image configure $linenum.0 -image $break_images($img_name)
}
}
# ------------------------------------------------------------------
# METHOD: removeBreakTag - remove a break tag (breakpoint or tracepoint)
# from the given line. If this is the last break tag on the
# line reinstall the break_rgn_tag
# ------------------------------------------------------------------
itcl::body SrcTextWin::removeBreakTag {win linenum tag } {
# debug "$win $linenum $tag"
set tag_list [$win tag names $linenum.0]
if {[set pos [lsearch -exact $tag_list $tag]] == -1} {
debug "Tried to remove non-existant tag $tag"
return
} else {
set tag_list [lreplace $tag_list $pos $pos]
}
# Use the range of the removed tag for any insertions, so we don't
# have to hard code it here.
set stop [lindex [$win tag nextrange $tag \
$linenum.0 "$linenum.0 lineend"] 1]
$win tag remove $tag $linenum.0 "$linenum.0 lineend"
# Now check what other tags are on this line. If there are both bp & tp
# tags, also remove the joint tag, otherwise install the break_rgn_tag.
switch -glob $tag {
*bp_tag {
set only_one_tag [expr [set next_tag_index \
[lsearch -glob $tag_list tp_tag]] == -1]
}
tp_tag {
# Got to find out what kind of tag is here...
set only_one_tag [expr [set next_tag_index \
[lsearch -glob $tag_list *bp_tag]] == -1]
}
}
if {$only_one_tag} {
catch {$win image configure $linenum.0 -image {}}
$win delete $linenum.0
$win insert $linenum.0 "-"
$win tag add break_rgn_tag $linenum.0 $stop
} else {
set other_tag [lindex $tag_list $next_tag_index]
set img_name [string range $other_tag 0 \
[expr [string length $other_tag] - 5]]
$win image configure $linenum.0 -image $break_images($img_name)
$win tag remove bp_and_tp_tag $linenum.0 "$linenum.0 lineend"
}
}
# ------------------------------------------------------------------
# PUBLIC METHOD: breakpoint - Handle a breakpoint create, delete,
# or modify event from the backend.
# ------------------------------------------------------------------
itcl::body SrcTextWin::breakpoint {bp_event} {
bp [$bp_event get action] [$bp_event get number] [$bp_event get address] \
[$bp_event get line] [$bp_event get file] [$bp_event get disposition] \
[$bp_event get enabled] [$bp_event get thread]
}
# ------------------------------------------------------------------
# PUBLIC METHOD: tracepoint - Handle a tracepoint create, delete,
# modify event from the backend.
# ------------------------------------------------------------------
itcl::body SrcTextWin::tracepoint {tp_event} {
bp [$tp_event get action] [$tp_event get number] [$tp_event get address] \
[$tp_event get line] [$tp_event get file] tracepoint \
[$tp_event get pass_count]
}
# ------------------------------------------------------------------
# METHOD: bp - set and remove breakpoints
#
# if $addr is valid, the breakpoint will be set in the assembly or
# mixed window at that address. If $line and $file are valid,
# a breakpoint will be set in the source window if appropriate.
# ------------------------------------------------------------------
itcl::body SrcTextWin::bp {action bpnum addr {linenum {}} {file {}} {type 0} {enabled 0} {thread -1}} {
# debug "$action addr=$addr line=$linenum file=$file type=$type current(filename)=$current(filename)"
switch $current(mode) {
SOURCE {
if {[string compare $file $current(filename)] == 0 && $linenum != {}} {
do_bp $twin $action $linenum $type $bpnum $enabled $thread 0
}
}
SRC+ASM {
if {$addr != {} && [info exists _map($Cname,pc=$addr)]} {
do_bp $bwin $action $_map($Cname,pc=$addr) $type $bpnum \
$enabled $thread 1
}
if {[string compare $file $current(filename)] == 0 && $linenum != {}} {
do_bp $twin $action $linenum $type $bpnum $enabled $thread 0
}
}
ASSEMBLY {
if {$addr != {} &&[info exists _map($Cname,pc=$addr)]} {
do_bp $twin $action $_map($Cname,pc=$addr) $type $bpnum \
$enabled $thread 1
}
}
MIXED {
if {$addr != {} && [info exists _map($Cname,pc=$addr)]} {
do_bp $twin $action $_map($Cname,pc=$addr) $type $bpnum \
$enabled $thread 1
}
}
}
}
# ------------------------------------------------------------------
# METHOD: do_bp - bp helper function
# ------------------------------------------------------------------
itcl::body SrcTextWin::do_bp { win action linenum type bpnum enabled thread asm} {
# debug "$action line=$linenum type=$type bpnum=$bpnum enabled=$enabled thread=$thread"
if {$dont_change_appearance} {
return
}
if {$action == "delete" && [string compare $type tracepoint] != 0} {
# make sure there are no more breakpoints on
# this line.
if {!$asm} {
set bps [gdb_find_bp_at_line $current(filename) $linenum]
} else {
if {[info exists _map($Cname,line=$linenum)]} {
set bps [gdb_find_bp_at_addr $_map($Cname,line=$linenum)]
} else {
set bps {}
}
}
if {[llength $bps] > 0} {
foreach b $bps {
if {$b != $bpnum} {
# OK we found another BP on this line.
# So we really just want to modify whats
# displayed on the line instead of deleting it.
# Also, for lack of a better solution, we will
# just display an image corresponding to the
# first found BP. If you have a temporary and
# a perm BP on the same line, the image for the one
# with the lower bpnum will be displayed.
set inf [gdb_get_breakpoint_info $b]
set action "modify"
set type [lindex $inf 6]
set bpnum $b
break
}
}
}
}
if {[string compare $type "tracepoint"] == 0} {
if {[string compare $action "delete"] != 0
&& [lindex [gdb_get_tracepoint_info $bpnum] 4] == 0} {
set type disabled_tracepoint
}
} else {
if {$enabled == "0" } {
set type disabled_bp
} elseif {$thread != "-1"} {
set type thread
}
}
switch $type {
donttouch {
set tag_type bp_tag
set remove_type disabled_bp_tag
}
delete {
set tag_type temp_bp_tag
}
disabled_bp {
set tag_type disabled_bp_tag
set remove_type bp_tag
}
tracepoint {
set tag_type tp_tag
set remove_type disabled_tp_tag
}
disabled_tracepoint {
set tag_type disabled_tp_tag
set remove_type tp_tag
}
thread {
set tag_type thread_bp_tag
}
default {
dbug E "UNKNOWN BP TYPE action=\"$action\" type=\"$type\""
$win insert $linenum.0 "X" bp_tag
set tag_type bp_tag
}
}
if {[string compare $action "delete"] == 0} {
removeBreakTag $win $linenum $tag_type
} else {
if {[string compare $action "modify"] == 0 && $remove_type != ""} {
removeBreakTag $win $linenum $remove_type
}
insertBreakTag $win $linenum $tag_type
}
}
# ------------------------------------------------------------------
# METHOD: hasBP - see if a line number has a breakpoint set
# ------------------------------------------------------------------
itcl::body SrcTextWin::hasBP {win line} {
if {$win == ""} {
set win $popups(saved_win)
}
if {[lsearch -glob [$win tag names $line.0] *bp_tag] >= 0} {
return 1
}
return 0
}
# ------------------------------------------------------------------
# METHOD: hasTP - see if a line number has a tracepoint set
# ------------------------------------------------------------------
itcl::body SrcTextWin::hasTP {win line} {
if {$win == ""} {
set win $popups(saved_win)
}
if {[lsearch -exact [$win tag names $line.0] tp_tag] == 1} {
return 1
}
return 0
}
# ------------------------------------------------------------------
# METHOD: report_source_location
#
# This function reports the "current" location in the source
# window, where current means what gdb_loc would return, if
# that point is actually visible in the window, or the middle
# of the current window, if that point is not visible.
#
# Return:
# The gdb_loc result for the location found
# ------------------------------------------------------------------
itcl::body SrcTextWin::report_source_location {} {
if {$current(filename) == ""} {
error "No source file in window"
}
# Figure out if the return from gdb_loc is visible.
set not_visible 1
if {![catch {gdb_loc} loc_info]} {
set loc_long_name [lindex $loc_info 2]
set loc_line [lindex $loc_info 3]
# debug "Got loc_info: \"$loc_info\" and filename $current(filename) long_name: $loc_long_name"
if {[string compare $current(filename) $loc_long_name] != 0} {
set not_visible 1
} else {
foreach {name line} [lookup_line $twin 1] {
break
}
if {$line < $loc_line} {
foreach {name line} [lookup_line $twin [winfo height $twin]] {
break
}
if {$line > $loc_line} {
set not_visible 0
}
}
}
} else {
debug "gdb_loc returned $loc_info"
}
if {$not_visible} {
set y [expr int([winfo height $twin] / 2)]
foreach {name line addr type} [lookup_line $twin $y] {
break
}
switch $type {
src {
return [gdb_loc $name:$addr]
}
asm {
return [gdb_loc *$addr]
}
}
} else {
return $loc_info
}
}
# ------------------------------------------------------------------
# METHOD: lookup_line - translated win & y position line info
#
# If win is {}, or y is -1, then the saved values from the popup
# array are used.
#
# Return:
# name - the fileName
# line - the line number in the text widget
# addr - the source line number, if in source mode, the
# address if in assembly mode, and if in mixed mode,
# the line if it is a source line, or the address if it
# is an assembly line
# type - src if it is a source line, asm if an assembly line.
# set_cmd - for convenience, this is the command needed to set a
# breakpoint at this address.
# ------------------------------------------------------------------
itcl::body SrcTextWin::lookup_line {win y} {
#debug "$win $y"
if {$y == -1} {
set y $popups(saved_y)
}
if {$win == {}} {
set win $popups(saved_win)
}
scan [$win index @0,$y] "%d." line
set name [lindex [::file split $current(filename)] end]
# If we are in the SOURCE window (either because the mode is SOURCE,
# or SRC+ASM, and we are in the upper pane, then return the
if {([string compare $current(mode) SOURCE] == 0)
|| ([string compare $current(mode) SRC+ASM] == 0
&& [string compare $win $twin] == 0)} {
set addr $line
set type "src"
} else {
if {[info exists _map($Cname,line=$line)]} {
set addr $_map($Cname,line=$line)
set type "asm"
} else {
# This is a source line in MIXED mode
set line_contents [$win get $line.0 "$line.0 lineend"]
#debug "Looking at line: $line contents: \"$line_contents\""
regexp "^\t(\[0-9\]*)" $line_contents match srcline
set addr $srcline
set type "src"
}
}
switch $type {
asm {
set set_cmd [list gdb_set_bp_addr $addr]
}
src {
set set_cmd [list gdb_set_bp $current(filename) $addr]
}
}
#debug "Lookup line returning [list $name $line $addr $type $set_cmd]"
return [list $name $line $addr $type $set_cmd]
}
# ------------------------------------------------------------------
# METHOD: continue_to_here - Advance to the line pointed to by the
# y coordinate in the window win. If win is {} or y is -1, the values
# saved in the popups array are used.
#
# The threads parameter is not currently used.
# ------------------------------------------------------------------
itcl::body SrcTextWin::continue_to_here {{win {}} {y -1} {threads -1}} {
# Look up the line... This foreach is an lassign...
foreach {name line addr type set_cmd} [lookup_line $win $y] {
break
}
set dont_change_appearance 1
foreach i [gdb_get_breakpoint_list] {
set enabled($i) [lindex [gdb_get_breakpoint_info $i] 5]
}
gdb_cmd "disable"
eval $set_cmd temp $threads
gdb_immediate "continue"
gdb_cmd "enable"
foreach i [gdb_get_breakpoint_list] {
if {![info exists enabled($i)]} {
gdb_cmd "delete $i"
} elseif {!$enabled($i)} {
gdb_cmd "disable $i"
}
}
set dont_change_appearance 0
}
# ------------------------------------------------------------------
# METHOD: jump_to_here - Advance to the line pointed to by the
# y coordinate in the window win. If win is {} or y is -1, the values
# saved in the popups array are used.
#
# The threads parameter is not currently used.
# ------------------------------------------------------------------
itcl::body SrcTextWin::jump_to_here {{win {}} {y -1} {threads -1}} {
# Look up the line... This foreach is an lassign...
foreach {name line addr type set_cmd} [lookup_line $win $y] {
break
}
# Unfortunately we cant set the pc to a linespec and we have to do a
# trick with a temporary breakpoint and the jump command.
# FIXME: Get the address from the linespec.
# FIXME: Even in the case we do have an address, I was not able to just
# change the PC and get things updated wright. While I work on that,
# I will use the temp breakpoint and jump trick for that case as well.
set dont_change_appearance 1
foreach i [gdb_get_breakpoint_list] {
set enabled($i) [lindex [gdb_get_breakpoint_info $i] 5]
}
gdb_cmd "disable"
if {$type == "asm"} {
gdb_immediate "tbreak *$addr"
gdb_immediate "jump *$addr"
} else {
eval $set_cmd temp $threads
gdb_immediate "jump $name:$line"
}
gdb_cmd "enable"
foreach i [gdb_get_breakpoint_list] {
if {![info exists enabled($i)]} {
gdb_cmd "delete $i"
} elseif {!$enabled($i)} {
gdb_cmd "disable $i"
}
}
set dont_change_appearance 0
}
# ------------------------------------------------------------------
# METHOD: set_bp_at_line - called when an empty break tag is clicked on
#
# When "threads" is set it means to set a bp on each thread in the list.
# ------------------------------------------------------------------
itcl::body SrcTextWin::set_bp_at_line {{type N} {win {}} {y -1} {threads "-1"}} {
# debug "$win $y $type $current(filename) Tracing=$Tracing"
if {$Running} {return}
# Look up the line... This foreach is an lassign...
foreach {name line addr addr_type set_cmd} [lookup_line $win $y] {
break
}
foreach th $threads {
switch $type {
N {
if {[catch {eval $set_cmd normal $th} msg]} {
dbug W $msg
}
}
T {
if {[catch {eval $set_cmd temp $th} msg]} {
dbug W $msg
}
}
}
}
}
# ------------------------------------------------------------------
# METHOD: enable_disable_at_line - Enable or disable breakpoint
# ------------------------------------------------------------------
itcl::body SrcTextWin::enable_disable_at_line {action} {
if {$Running} {
return
}
# FIXME: should this work on $bwin as well? In that case we'd need
# a `win' argument...
set y $popups(saved_y)
$twin tag remove _show_variable 1.0 end
set line [lindex [split [$twin index @0,$y] .] 0]
set bps ""
switch $current(mode) {
SRC+ASM {
}
ASSEMBLY {
if {[info exists _map($Cname,line=$line)]} {
set addr $_map($Cname,line=$line)
set bps [gdb_find_bp_at_addr $addr]
} else {
return
}
}
MIXED {
if {[info exists _map($Cname,line=$line)]} {
set addr $_map($Cname,line=$line)
set bps [gdb_find_bp_at_addr $addr]
} else {
return
}
}
}
if {$bps == ""} {
set bps [gdb_find_bp_at_line $current(filename) $line]
}
# ACTION is `enable' or `disable'
gdb_cmd "$action $bps"
}
# ------------------------------------------------------------------
# METHOD: remove_bp_at_line - called when a bp tag is clicked on
#
# when "threads" is set it means to set a bp on each thread in the list.
# ------------------------------------------------------------------
itcl::body SrcTextWin::remove_bp_at_line {{win {}} {y -1}} {
if {$Running} {return}
# Look up the line... This foreach is an lassign...
foreach {name line addr type} [lookup_line $win $y] {
break
}
# FIXME: if there are multiple bp/tp at a single line,
# we will (right now) always take the first one we find...
switch $type {
src { set bps [gdb_find_bp_at_line $name $addr] }
asm { set bps [gdb_find_bp_at_addr $addr] }
}
set number [lindex $bps 0]
gdb_cmd "delete $number"
}
# ------------------------------------------------------------------
# METHOD: set_tp_at_line - called when an empty break region tag is clicked on
#
# when "threads" is set it means to set a bp on each thread in the list.
# ------------------------------------------------------------------
itcl::body SrcTextWin::set_tp_at_line {{win {}} {y -1}} {
# debug "$win $y $current(filename) Tracing=$Tracing"
if {$Running} {return}
# Look up the line... This foreach is an lassign...
foreach {name line addr type} [lookup_line $win $y] {
break
}
switch $type {
src {
after idle [list ManagedWin::open TraceDlg -File $name -Lines $addr]
}
asm {
after idle [list ManagedWin::open TraceDlg -File $name -Addresses [list $addr]]
}
}
}
# ------------------------------------------------------------------
# METHOD: next_hit_at_line - Finds the next trace hit at the line
# given by win & y...
#
# ------------------------------------------------------------------
itcl::body SrcTextWin::next_hit_at_line {{win {}} {y -1}} {
# debug "$win $y $current(filename) Tracing=$Tracing"
if {!$Browsing} {return}
# Look up the line... This foreach is an lassign...
foreach {name line addr type} [lookup_line $win $y] {
break
}
# If the line and the addr are the same, then the specification was
# given by line. Otherwise is was a memory address.
switch $type {
src {
tfind_cmd "tfind line $name:$addr"
}
asm {
tfind_cmd "tfind line *$addr"
}
}
}
# ------------------------------------------------------------------
# METHOD: remove_tp_at_line - called when a tp tag is clicked on
#
# when "threads" is set it means to set a bp on each thread in the list.
# ------------------------------------------------------------------
itcl::body SrcTextWin::remove_tp_at_line {{win {}} {y -1}} {
if {$Running} {return}
# Look up the line... This foreach is an lassign...
foreach {name line addr type} [lookup_line $win $y] {
break
}
switch $type {
src {
set tp_num [gdb_tracepoint_exists $name:$addr]
}
asm {
set tp_num [gdb_tracepoint_exists *$addr]
}
}
if {$tp_num != -1} {
if {[catch {gdb_cmd "delete tracepoints $tp_num"} errTxt]} {
tk_messageBox -type error -message "Could not delete tracepoint number $tp_num
Error was: $errTxt"
}
}
}
# ------------------------------------------------------------------
# METHOD: do_tag_popup - The tag bind function for breakpoint popups
# ------------------------------------------------------------------
itcl::body SrcTextWin::do_tag_popup {name X Y y} {
# debug "$name $X $Y $y"
if {$Running || [winfo ismapped $popups($name)]} {
return
}
set popups(saved_y) $y
set popups(saved_win) [winfo containing -displayof $itk_interior $X $Y]
# Hide variable balloons before showing the popup
$twin tag remove _show_variable 1.0 end
balloon withdraw $twin
tk_popup $popups($name) $X $Y
}
# ------------------------------------------------------------------
# METHOD: do_source_popup - tag bind function for source popups
# ------------------------------------------------------------------
itcl::body SrcTextWin::do_source_popup { X Y x y } {
if {$Running || [winfo ismapped $popups(source)]} {
return
}
# Figure out what window we are over...
set win [winfo containing -displayof $itk_interior $X $Y]
# Hide variable balloons before showing the popup
$win tag remove _show_variable 1.0 end
balloon withdraw $win
catch {$_balloon_var delete}
# Try to get the selection. If you fail, get the word around the
# click point.
# Note that we don't have to worry about the user clicking over the
# break area, since the break_rgn_tag will override this...
set hit_point [$win index @$x,$y]
if {([$win tag ranges sel] != "")
&& ([$win compare sel.first < $hit_point]
&& [$win compare $hit_point < sel.last])} {
set sel_first [$win index sel.first]
set sel_last [$win index sel.last]
# If there was a selection, see if it spans multiple lines.
scan $sel_first "%d.%d" range_low sel_start_char
scan $sel_last "%d.%d" range_high sel_end_char
if {$range_low == $range_high} {
set range -1
set target_range [$win get sel.first sel.last]
} else {
# If the selection encompasses multiple lines, we only care about
# the start and ending line numbers
set range 1
}
} else {
set target_range [$win get "$hit_point wordstart" "$hit_point wordend"]
set range 0
}
$popups(source) delete 0 end
if {$range && $Tracing} {
# If the selection spans more than one line, it can't be a variable name...
# So just insert the tracepoint range item
$popups(source) add command -label "Set Tracepoint Range" \
-command "$this tracepoint_range $win $range_low $range_high"
$popups(source) add separator
} elseif {$range != 1} {
# RANGE = -1 means that we have already found the word we want (it was
# a selection)...
# RANGE = 1 means we got the word around the point, and we are just saving
# getVariable the trouble of parsing it again.
if {$range == -1} {
set variable $target_range
} else {
set variable [lindex [getVariable -1 -1 $target_range] 0]
}
if {$variable != ""} {
# LAME: check to see if VARIABLE is really a number (constants??)
set is_var [catch {expr {$variable+1}}]
if {$is_var} {
$popups(source) add command -label "Add $variable to Watch" \
-command [list $this addToWatch $variable]
$popups(source) add command -label "Dump Memory at $variable" \
-command [list ManagedWin::open MemWin -force -addr_exp $variable]
$popups(source) add command -label "Set Breakpoint at $variable" \
-command [list gdb_cmd "break $variable"]
$popups(source) add separator
}
}
}
$popups(source) add command -label "Open Another Source Window" \
-command {ManagedWin::open SrcWin -force}
$popups(source) add command -label "Open Source in external editor" \
-command [code $parent edit]
tk_popup $popups(source) $X $Y
}
# ------------------------------------------------------------------
# METHOD: addToWatch - add a variable to the watch window
# ------------------------------------------------------------------
itcl::body SrcTextWin::addToWatch {var} {
[ManagedWin::open WatchWin] add $var
}
# ------------------------------------------------------------------
# METHOD: do_key -- wrapper for all key bindings
# ------------------------------------------------------------------
itcl::body SrcTextWin::do_key {key} {
if {!$Running} {
switch $key {
print { print $top }
download { Download::download_it }
run { $parent inferior run }
stack { ManagedWin::open StackWin }
registers { ManagedWin::open RegWin }
memory { ManagedWin::open MemWin }
watch { ManagedWin::open WatchWin }
locals { ManagedWin::open LocalsWin }
breakpoints { ManagedWin::open BpWin }
console { ManagedWin::open Console }
step { $parent inferior step }
next { $parent inferior next }
finish { $parent inferior finish }
continue { $parent inferior continue }
stepi { $parent inferior stepi }
nexti { $parent inferior nexti }
up { catch {gdb_cmd up} }
down { catch {gdb_cmd down} }
quit { gdbtk_quit }
tdump { ManagedWin::open TdumpWin }
tracepoints { ManagedWin::open BpWin -tracepoints 1}
tfind_next { catch {gdb_immediate tfind} }
tfind_prev { catch {gdb_immediate "tfind -"} }
tfind_start { catch {gdb_immediate "tfind start"} }
tfind_line { catch {gdb_immediate "tfind line"} }
tfind_tp { catch {gdb_immediate "tfind tracepoint"} }
open { catch {_open_file} }
close { catch {_close_file} }
browser { catch {ManagedWin::open BrowserWin} }
thread_list { catch {ManagedWin::open ProcessWin} }
debug { catch {ManagedWin::open DebugWin} }
kod { catch {ManagedWin::open KodWin} }
attach { catch {gdbtk_attach_native} }
default {
dbug E "Unknown key binding: \"$key\""
}
}
} else {
# debug "ignoring keypress -- running"
}
}
# ------------------------------------------------------------------
# METHOD: mode_get - get the source mode
# ------------------------------------------------------------------
itcl::body SrcTextWin::mode_get {} {
return $current(mode)
}
# ------------------------------------------------------------------
# METHOD: mode_set - change the source mode
# ------------------------------------------------------------------
itcl::body SrcTextWin::mode_set {new_mode {go 1}} {
debug "$new_mode"
if {$new_mode != $current(mode)} {
if {$current(mode) == "SRC+ASM"} {
if {$_bpane != ""} {$itk_interior.p hide $_bpane}
set _bpane ""
set _bwin ""
}
set current(mode) $new_mode
set mode_changed 1
if {$go} {
location $current(tag) $current(filename) $current(funcname) \
$current(line) $current(addr) $pc(addr) $current(lib)
}
}
}
# ------------------------------------------------------------------
# METHOD: cancelMotion - cancel any pending motion callbacks for
# the source window's variable balloons
# ------------------------------------------------------------------
itcl::body SrcTextWin::cancelMotion {} {
catch {after cancel $timeoutID}
}
# ------------------------------------------------------------------
# METHOD: motion - callback for mouse motion within the source
# window's text widget
# ------------------------------------------------------------------
itcl::body SrcTextWin::motion {type win x y} {
global gdb_running
cancelMotion
# The showBalloon method can sometimes raise errors (for instance in
# assembly code with no sources, and when gdb coughs over a path
# that contains a space. These functions should error quietly.
# but write to the debug window so we can trace problems.
if {$type == "var"} {
set cmd_bit ""
} else {
set cmd_bit BP
}
set cmd_line [format {
if {[catch {%s show%sBalloon %s %d %d} err]} {
debug "show%sBalloon got error: $err"
}
} $this $cmd_bit $win $x $y $cmd_bit]
set timeoutID [after $TimeOut $cmd_line]
}
# ------------------------------------------------------------------
# METHOD: showBPBalloon - show BP information in a balloon
# ------------------------------------------------------------------
itcl::body SrcTextWin::showBPBalloon {win x y} {
if {$Running} { return }
$win tag remove _show_variable 1.0 end
set line [lindex [split [$win index @0,$y] .] 0]
set bps ""
switch $current(mode) {
SRC+ASM {
if {$win == $bwin} {
if {[info exists _map($Cname,line=$line)]} {
set addr $_map($Cname,line=$line)
set bps [gdb_find_bp_at_addr $addr]
} else {
return
}
}
}
ASSEMBLY {
if {[info exists _map($Cname,line=$line)]} {
set addr $_map($Cname,line=$line)
set bps [gdb_find_bp_at_addr $addr]
} else {
return
}
}
MIXED {
if {[info exists _map($Cname,line=$line)]} {
set addr $_map($Cname,line=$line)
set bps [gdb_find_bp_at_addr $addr]
} else {
return
}
}
}
if {$bps == ""} {
set bps [gdb_find_bp_at_line $current(filename) $line]
}
set str ""
set need_lf 0
foreach b $bps {
set bpinfo [gdb_get_breakpoint_info $b]
lassign $bpinfo file func linenum addr type enabled disposition \
ignore_count commands cond thread hit_count user_specification
set file [lindex [file split $file] end]
if {$enabled} {
set enabled "ENA"
} else {
set enabled "DIS"
}
if {$need_lf} {append str \n}
append str [format "breakpoint %d at %s:%d (%s)\n %s %s %s" \
$b $file $linenum $addr $enabled $type $disposition]
if {$thread != "-1"} {
append str "\n threads: $thread"
}
if {$ignore_count != 0} {
append str "\n ignore: $ignore_count"
}
if {$cond != ""} {
append str "\n condition: $cond"
}
if {$commands != ""} {
if {[string length $commands] > 50} {
append str "\n commands: [string range $commands 0 50] ..."
} else {
append str "\n commands: $commands"
}
}
set need_lf 1
}
# Scope out which break type is set here, and use the tag to get
# the break region range...
set tag_list [$win tag names $line.0]
set break_tag [lindex $tag_list [lsearch -glob $tag_list *bp_tag]]
set end [lindex [$win tag nextrange $break_tag $line.0 $line.end] 1]
if {$end != ""} {
$win tag add _show_variable $line.0 $end
balloon register $win $str _show_variable
balloon show $win _show_variable 1
}
}
# ------------------------------------------------------------------
# METHOD: showBalloon - (possibly) show a variable's value in
# a balloon-help widget
# ------------------------------------------------------------------
itcl::body SrcTextWin::showBalloon {win x y} {
if {$Running} { return }
$twin tag remove _show_variable 1.0 end
catch {tmp delete}
if {[catch {getVariable $x $y} variable]} {
return
}
if {[llength $variable] != 3} {
return
}
# We get the variable name, and its start and stop indices in the text
# widget, so all we need to do is set the tag and register the balloon help
set varName [lindex $variable 0]
set start [lindex $variable 1]
set stop [lindex $variable 2]
# Get the address associated with this line
foreach {file text_line source_line type} [lookup_line $twin $y] {
break
}
# Reduce the areas over which we will show balloons.
# 1) Only pop up a balloon if we are over the function in
# the currently selected frame, or in the static data for
# the file.
# 2) We would also like to exclude cases where the line that
# under the mouse cursor does not contain executable code,
# but we can't since gdb considers continuation lines to not
# have executible code so we would lose on these...
set cur_fn [lindex [gdb_loc $file:$source_line] 1]
set selected_frame_fn [lindex [gdb_loc] 1]
if {[string compare $cur_fn $selected_frame_fn] == 0} {
# Create the variable object
catch {$_balloon_var delete}
set err [catch {gdb_variable create -expr $varName} _balloon_var]
if {!$err} {
set value [balloon_value $_balloon_var]
if {$value != ""} {
$win tag add _show_variable $start $stop
# display variable's value
balloon register $twin "$varName=$value" _show_variable
balloon show $win _show_variable
} else {
# No value/error. Don't show it.
catch {$_balloon_var delete}
set _balloon_var {}
}
} else {
set _balloon_var {}
}
} else {
set _balloon_var {}
}
}
# ------------------------------------------------------------------
# METHOD: getVariable - get the name of the 'variable' under the
# mouse pointer in the text widget
# ------------------------------------------------------------------
itcl::body SrcTextWin::getVariable {x y {line {}}} {
#debug "$x $y $line"
set hit_point [$twin index @$x,$y]
if {$x != -1 && $y != -1} {
# If we are over a selection, just report that:
if {([$twin tag ranges sel] != "")
&& ([$twin compare sel.first < $hit_point]
&& [$twin compare $hit_point < sel.last])} {
return [list [$twin get sel.first sel.last] [$twin index sel.first] [$twin index sel.last]]
}
# Since we will only be concerned with this line, get it
set line [$twin get "$hit_point linestart" "$hit_point lineend"]
# debug "new line=$line"
set simple 0
} else {
# This is not quite right -- still want constants to appear...
set simple 1
}
# The index into LINE that contains the char at which the pointer hangs
set a [split [$twin index @$x,$y] .]
set lineNo [lindex $a 0]
set index [lindex $a 1]
set s [string range $line $index end]
set last {}
foreach char [split $s {}] {
if {[regexp -- {([^a-zA-Z0-9_>.-])} $char dummy]} {
break
}
lappend last $char
}
set last [string trimright [join $last {}] ->]
# Decrement index for string -- will need to increment it later
incr index -1
set tmp [string range $line 0 $index]
set s {}
foreach char [split $tmp {}] {
set s [linsert $s 0 $char]
}
set first {}
foreach char $s {
if {[regexp -- {([^a-zA-Z0-9_>.-])} $char dummy]} {
break
}
set first [linsert $first 0 $char]
}
#set first [string trimleft [join $first {}] ->]
set first [join $first {}]
#debug "FIRST=$first\nLAST=$last"
# Validate the variable
set variable [string trim $first$last \ ]
if {!$simple && ![regexp {^[a-zA-Z_]} $variable dummy]} {
#debug "Rejecting: $variable"
return {}
}
incr index
# Find the boundaries of this word in the text box
set a [string length $first]
set b [string length $last]
# Gag! If there is a breakpoint at a line, this is off by one!
if {[hasBP $twin $lineNo] || [hasTP $twin $lineNo]} {
incr a -1
incr b 1
}
set start "$lineNo.[expr {$index - $a}]"
set end "$lineNo.[expr {$index + $b}]"
return [list $variable $start $end]
}
# ------------------------------------------------------------------
# METHOD: trace_help - update statusbar with ballon help message
# ------------------------------------------------------------------
itcl::body SrcTextWin::trace_help {args} {
upvar #0 ${this}_balloon a
if {$a == ""} {
$parent set_status
} else {
$parent set_status $a 1
}
}
itcl::body SrcTextWin::line_is_executable {win line} {
# there should be an image or a "-" on the line
set res [catch {$win image cget $line.0 -image}]
if {!$res || [$win get $line.0] == "-"} {
return 1
}
return 0
}
# ------------------------------------------------------------------
# METHOD: tracepoint_range - create tracepoints at every line in
# a range of lines on the screen
# ------------------------------------------------------------------
itcl::body SrcTextWin::tracepoint_range {win low high} {
# debug "$win $low $high"
switch $current(mode) {
SOURCE {
set lines {}
for {set i $low} {$i <= $high} {incr i} {
if {[line_is_executable $win $i]} {
lappend lines $i
}
}
}
ASSEMBLY {
set addrs {}
for {set i $low} {$i <= $high} {incr i} {
lappend addrs $_map($Cname,line=$i)
}
}
MIXED {
set addrs {}
for {set i $low} {$i <= $high} {incr i} {
if {[line_is_executable $win $i]} {
lappend addrs $_map($Cname,line=$i)
}
}
}
SRC+ASM {
if {$win == $awin} {
# Assembly
set addrs {}
for {set i $low} {$i <= $high} {incr i} {
lappend addrs $_map($Cname,line=$i)
}
} else {
# Source
set lines {}
for {set i $low} {$i <= $high} {incr i} {
if {[line_is_executable $win $i]} {
lappend lines $i
}
}
}
}
}
if {[info exists lines]} {
# debug "Got executible lines: $lines"
if {[llength $lines]} {
set name [::file tail $current(filename)]
ManagedWin::open TraceDlg -File $name -Lines $lines
}
} elseif {[info exists addrs]} {
# debug "Got executible addresses: $addrs"
if {[llength $addrs]} {
set name [::file tail $current(filename)]
ManagedWin::open TraceDlg -File $name -Addresses $addrs
}
} else {
# debug "Got no executible lines in the selected range..."
}
# Clear the selection -- it looks a lot better.
$twin tag remove sel 1.0 end
}
# ------------------------------------------------------------------
# METHOD: search - search for text or jump to a specific line
# in source window, going in the specified DIRECTION.
# ------------------------------------------------------------------
itcl::body SrcTextWin::search {exp direction} {
if {$exp != ""} {
set result {}
if {[regexp {^@([0-9]+)} $exp dummy index]} {
append index .0
set end [$twin index "$index lineend"]
} else {
set index [$twin search -exact -count len -$direction -- $exp $SearchIndex]
if {$index != ""} {
set end [split $index .]
set line [lindex $end 0]
set char [lindex $end 1]
set char [expr {$char + $len}]
set end $line.$char
set result "Match of \"$exp\" found on line $line"
if {$direction == "forwards"} {
set SearchIndex $end
} else {
set SearchIndex $index
}
}
}
if {$index != ""} {
# Highlight word and save index
$twin tag remove search 1.0 end
$twin tag add search $index $end
$twin see $index
} else {
set result "No match for \"$exp\" found"
}
return $result
} else {
$twin tag remove search 1.0 end
}
}
# -----------------------------------------------------------------------------
# NAME: SrcTextWin::LoadFromCache
#
# SYNOPSIS: LoadFromCache {w name asm lib}
#
# DESC: Looks up $name in the cache. If $name is cached, replace the
# pane $w with the cached pane. Otherwise create a new
# pane and scrolledtext widget and set _${w}pane and _${w}win.
#
# ARGS: w "t" or "b" (for Top and Bottom pane)
# name name to look for in cache. This will be a filename if
# we are filling in a source window, or an address
# otherwise.
# asm 'S' for source,
# 'A' for assembly mode
# 'M' for mixed mode.
# lib library name
#
# RETURNS: 0 - read from cache
# 1 - created new (blank) widget
# -1 - could not find the contents you are trying to load,
# so far this only happens for "Source" files.
#
# NOTES: If you call this and a new widget is created which cannot be
# filled in later due to errors, call UnLoadFromCache.
# -----------------------------------------------------------------------------
itcl::body SrcTextWin::LoadFromCache {w name asm lib} {
debug "LoadFromCache $w $name $asm"
global tcl_platform
upvar ${w}win win
upvar _${w}pane pane
if {[string compare gdbtk_scratch_widget $name]} {
append full_name $name "," $asm "," $lib
} else {
set full_name $name
}
set loadingSource [expr ![string compare $asm "S"]]
set oldpane $pane
if {[info exists Stwc($full_name:pane)]} {
debug "READING CACHE $full_name->$Stwc($full_name:pane)"
set pane $Stwc($full_name:pane)
if {$oldpane != ""} {
$itk_interior.p replace $oldpane $pane
} else {
$itk_interior.p show $pane
}
set win [[$itk_interior.p childsite $pane].st component text]
if {!$loadingSource} {
set Cname $full_name
}
# If the text in this cache file is dirty, clean the window, and
# return 1, which will tell the caller to refill it. Otherwise
# return 0, and the caller will just display the window.
if {$Stwc($name:dirty)} {
$win delete 0.0 end
set res 1
set Stwc($name:dirty) 0
} else {
set res 0
}
} else {
debug "name=$name"
# If we are trying to load a source file, check the time
# to see if we need to update it. If we can't stat the
# file then we probably can't open it either, so error
# out.
if {$loadingSource} {
if {[string compare $tcl_platform(platform) "windows"] == 0} {
set f [ide_cygwin_path to_win32 $name]
} else {
set f $name
}
if {[catch {file mtime $f} file_time]} {
debug "Could not stat file \"$f\" - \"$file_time\""
return -1
} else {
set Stwc($full_name:pane) pane$filenum
set Stwc($name:mtime) $file_time
}
} else {
# FIXME: This is wrong. For Assembly files we need to
# check whether the executable is newer than the cached
# disassembly. For mixed files, we need to check BOTH
# the source file mtime, and the executable time.
set Stwc($full_name:pane) pane$filenum
set Stwc($name:mtime) 0
}
set Stwc($full_name:pane) pane$filenum
set Stwc($name:dirty) 0
incr filenum
set pane $Stwc($full_name:pane)
debug "pane=$pane"
if {$oldpane != ""} {$itk_interior.p hide $oldpane}
$itk_interior.p add $pane
set p [$itk_interior.p childsite $pane]
set st [iwidgets::scrolledtext $p.st \
-hscrollmode dynamic -vscrollmode dynamic]
set win [$st component text]
if {!$loadingSource} {
set Cname $full_name
}
pack $st -expand yes -fill both
set res 1
}
# reconfigure in case some preferences have changed
config_win $win $asm
return $res
}
# ------------------------------------------------------------------
# METHOD: UnLoadFromCache - revert back to previously cached widget
# This is used when a new widget is created with LoadFromCache but
# there is a problem with filling the widget.
# ------------------------------------------------------------------
itcl::body SrcTextWin::UnLoadFromCache {w oldpane name asm lib} {
# debug "$w $oldpane $name"
upvar ${w}win win
upvar _${w}pane pane
# debug "pane=$pane win=$win"
set full_name ${name},${asm},${lib}
$itk_interior.p delete $pane
foreach elem [array names Stwc $full_name:*] {
unset Stwc($elem)
}
foreach elem [array names Stwc $name:*] {
unset Stwc($elem)
}
if {$oldpane != ""} {
$itk_interior.p show $oldpane
set pane $oldpane
set win [[$itk_interior.p childsite $pane].st component text]
}
}
# ------------------------------------------------------------------
# METHOD: print - print the contents of the text widget
# ------------------------------------------------------------------
itcl::body SrcTextWin::print {top} {
# FIXME
send_printer -ascii [$twin get 1.0 end] -parent $top
}
# ------------------------------------------------------------------
# METHOD: ask_thread_bp - prompt for thread(s) for BP
# ------------------------------------------------------------------
itcl::body SrcTextWin::ask_thread_bp {} {
# debug
if {[catch {gdb_cmd "info thread"} threads]} {
# failed. Just leave
return
}
set threads [split $threads \n]
set num_threads [expr {[llength $threads] - 1}]
if {$num_threads <= 0} {
show_warning "No threads were found.\nYou may only set breakpoints on threads\nthat have already been created."
return
}
set a [toplevel .[gensym]]
wm title $a "Thread Selection"
iwidgets::scrolledlistbox $a.slb \
-vscrollmode dynamic -hscrollmode dynamic \
-selectmode multiple -textfont global/fixed
set i [expr $num_threads - 1]
set width 0
foreach line $threads {
# Active line starts with "*"
if {[string index $line 0] == "*"} {
# strip off leading "*"
set line " [string trimleft $line "*"]"
}
# scan for GDB ID number at start of line
if {[scan $line "%d" id($i)] == 1} {
if {[string length $line] > $width} {
set width [string length $line]
}
$a.slb insert 0 $line
incr i -1
}
}
$a.slb configure -visibleitems ${width}x$num_threads
[$a.slb component listbox] configure -bg $::Colors(textbg) -fg $::Colors(textfg)
frame $a.b
button $a.b.ok -text OK -underline 0 -width 7 \
-command "$this do_thread_bp $a.slb"
button $a.b.cancel -text Cancel -width 7 -underline 0 -command "destroy $a"
pack $a.b.ok $a.b.cancel -side left
standard_button_box $a.b
pack $a.b -fill x -expand yes -side bottom -padx 5 -pady 5
center_window $a -over [winfo toplevel [namespace tail $this]]
pack $a.slb -side top -fill both -expand yes
bind $a.b.ok <Return> "$a.b.ok flash; $a.b.ok invoke"
focus $a.b.ok
}
# ------------------------------------------------------------------
# METHOD: do_thread_bp - callback from thread selection
# ------------------------------------------------------------------
itcl::body SrcTextWin::do_thread_bp {listbox} {
# debug "$listbox [$listbox curselection]"
set x ""
foreach i [$listbox curselection] {
lappend x $id($i)
}
$this set_bp_at_line N {} -1 $x
destroy [winfo toplevel $listbox]
}
# public method for testing use only!
itcl::body SrcTextWin::test_get {var} {
if {[array exists $var]} {
return [array get $var]
} else {
return [set $var]
}
}
# ------------------------------------------------------------------
# METHOD: get_file - Return name of current file.
# ------------------------------------------------------------------
itcl::body SrcTextWin::get_file {} {
return $current(filename)
}
# ------------------------------------------------------------------
# METHOD: clear_file - Clear out state so that user may load
# new executable. For the SrcTextWin class, this means:
#
# Delete all srctextwin caches
# Delete the variable balloon if it exists.
# Clear the screen.
# ------------------------------------------------------------------
itcl::body SrcTextWin::clear_file {} {
debug "In clear_file"
# delete all caches
_clear_cache
set oldpane {}
# clear window
# FIXME - We don't do this here, because is causes a wierd error
# where the "Source file more recent than executible" error gets
# for no apparent reason. This only effects the case where the
# user types just "file" in the command line, then the window will
# not get cleared.
# delete variable balloon
catch {$_balloon_var delete}
set _balloon_var {}
# reinit state
_initialize_srctextwin
# update the screen
update idletasks
}
itcl::body SrcTextWin::_initialize_srctextwin {} {
set pc(filename) ""
set pc(func) ""
set pc(line) 0
set pc(addr) ""
set pc(asm_line) 0
set pc(lib) ""
set current(filename) ""
set current(funcname) ""
set current(line) 0
set current(addr) ""
set current(asm_line) 0
set current(tag) "BROWSE_TAG"
set current(mode) "SOURCE"
set current(lib) ""
}
# ------------------------------------------------------------------
# METHOD: _clear_cache - Clear the cache
# ------------------------------------------------------------------
itcl::body SrcTextWin::_clear_cache {} {
# display empty scratch frame
set pane $Stwc(gdbtk_scratch_widget:pane)
set win [[$itk_interior.p childsite $pane].st component text]
$win delete 0.0 end
$itk_interior.p show $pane
# delete all cached frames
foreach p [array names Stwc *:pane] {
set p [lindex [split $p :] 0]
if {$p != "gdbtk_scratch_widget"} {
catch {
#debug "clearing cache: \"$p\""
$itk_interior.p delete $Stwc($p:pane)
unset Stwc($p:pane)
unset Stwc($p:mtime)
}
}
}
_initialize_srctextwin
set filenum 0
set Cname ""
set _tpane pane$filenum
incr filenum
set _bpane ""
}