| # Paned text widget for source code, for Insight |
| # Copyright (C) 1997, 1998, 1999, 2001, 2002, 2008 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 gdbtk_platform |
| |
| if [catch {gdb_find_file $filename} f] { |
| set r 1 |
| } elseif {$f == ""} { |
| set r 1 |
| } else { |
| if {[string compare $gdbtk_platform(os) "cygwin"] == 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 gdbtk_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 $gdbtk_platform(os) "cygwin"] == 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 "" |
| } |