gdb/gdbtk.tcl

   1 # GDB GUI setup
   2
   3 set cfile Blank
   4 set wins($cfile) .text
   5 set current_label {}
   6 set screen_height 0
   7 set screen_top 0
   8 set screen_bot 0
   9
  10 proc test {} {
  11         update_listing {termcap.c foo /etc/termcap 200}
  12 }
  13
  14 proc echo string {puts stdout $string}
  15
  16 proc gdbtk_tcl_fputs {arg} {
  17         .command.text insert end "$arg"
  18         .command.text yview -pickplace end
  19 }
  20
  21 proc gdbtk_tcl_flush {} {update idletasks}
  22
  23 proc gdbtk_tcl_query {message} {
  24         tk_dialog .query "gdb : query" "$message" {} 1 "No" "Yes"
  25         }
  26
  27 if [info exists env(EDITOR)] then {
  28         set editor $env(EDITOR)
  29         } else {
  30         set editor emacs
  31 }
  32
  33 proc gdbtk_tcl_start_variable_annotation {valaddr ref_type stor_cl cum_expr field type_cast} {
  34         echo "gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
  35 }
  36
  37 proc gdbtk_tcl_end_variable_annotation {} {
  38         echo gdbtk_tcl_end_variable_annotation
  39 }
  40
  41 proc insert_breakpoint_tag {win line} {
  42         $win configure -state normal
  43         $win delete $line.0
  44         $win insert $line.0 "B"
  45         $win tag add $line $line.0
  46         $win tag bind $line <1> {
  47 #               echo "tag %W %X %Y %x"
  48 #               echo "tag names [$wins($cfile) tag names]"
  49         }
  50
  51         $win configure -state disabled
  52 }
  53
  54 proc delete_breakpoint_tag {win line} {
  55         $win configure -state normal
  56         $win delete $line.0
  57         $win insert $line.0 " "
  58         $win tag delete $line
  59         $win configure -state disabled
  60 }
  61
  62 # Callback from GDB to notify us of breakpoint creation.
  63
  64 proc create_breakpoint {bpnum file line} {
  65         global wins
  66         global breakpoint_file
  67         global breakpoint_line
  68
  69 # Record breakpoint locations
  70
  71         set breakpoint_file($bpnum) $file
  72         set breakpoint_line($bpnum) $line
  73
  74 # If there isn't a window for this file, don't try to update it
  75
  76         if [info exists wins($file)] {
  77                 insert_breakpoint_tag $wins($file) $line
  78         }
  79 }
  80
  81 proc delete_breakpoint {bpnum file line} {
  82         global wins
  83         global breakpoint_file
  84         global breakpoint_line
  85
  86 # Save line number for later
  87
  88         set line $breakpoint_line($bpnum)
  89
  90 # Reset breakpoint annotation info
  91
  92         unset breakpoint_file($bpnum)
  93         unset breakpoint_line($bpnum)
  94
  95 # If there isn't a window for this file, don't try to update it
  96
  97         if [info exists wins($file)] {
  98                 delete_breakpoint_tag $wins($file) $line
  99         }
 100 }
 101
 102 # This is a callback from C code to notify us of breakpoint changes.  ACTION
 103 # can be one of create, delete, enable, or disable.
 104
 105 proc gdbtk_tcl_breakpoint {action bpnum file line} {
 106         ${action}_breakpoint $bpnum $file $line
 107 }
 108
 109 # Create the popup listing window menu
 110
 111 menu .breakpoint -cursor hand2
 112 .breakpoint add command -label Break
 113 .breakpoint add separator
 114 .breakpoint add command -label "Edit" -command {exec $editor +$selected_line $selected_file &}
 115 .breakpoint add command -label "Set breakpoint" -command {gdb_cmd "break $selected_file:$selected_line"}
 116 #.breakpoint add command -label "Clear breakpoint" -command {echo "Clear"}
 117 #.breakpoint add command -label "Enable breakpoint" -command {echo "Enable"}
 118 #.breakpoint add command -label "Disable breakpoint" -command {echo "Disable"}
 119
 120 # Come here when button is released in the popup menu
 121
 122 bind .breakpoint <Any-ButtonRelease-1> {
 123         global selected_win
 124
 125 # First, remove the menu, and release the pointer
 126
 127         .breakpoint unpost
 128         grab release .breakpoint
 129
 130 # Unhighlight the selected line
 131
 132         $selected_win tag delete breaktag
 133 #       echo "after deleting $selected_win [$selected_win tag names]"
 134 #       echo "grab [grab current]"
 135
 136 # Actually invoke the menubutton here!
 137
 138         tk_invokeMenu %W
 139 #       destroy .breakpoint
 140         grab release $selected_win
 141 }
 142
 143 # Button 1 has been pressed in a listing window.  Pop up a menu.
 144
 145 proc breakpoint_menu {win x y xrel yrel} {
 146         global wins
 147         global win_to_file
 148         global file_to_debug_file
 149         global highlight
 150         global selected_line
 151         global selected_file
 152         global selected_win
 153
 154         grab $win
 155
 156 #       echo "bpm grab current [grab current]"
 157
 158 # Map TK window name back to file name.
 159
 160         set file $win_to_file($win)
 161
 162         set pos [$win index @$xrel,$yrel]
 163
 164 # Record selected file and line for menu button actions
 165
 166         set selected_file $file_to_debug_file($file)
 167         set selected_line [lindex [split $pos .] 0]
 168         set selected_win $win
 169
 170 # Highlight the selected line
 171
 172         eval $win tag config breaktag $highlight
 173         $win tag add breaktag "$pos linestart" "$pos linestart + 1l"
 174
 175 # Post the menu near the pointer, (and grab it)
 176
 177         .breakpoint post [expr $x-[winfo width .breakpoint]/2] [expr $y-10]
 178         grab .breakpoint
 179 #       echo "after grab [grab current]"
 180 }
 181
 182 proc do_nothing {} {}
 183
 184 proc create_file_win {filename} {
 185         global breakpoint_file
 186         global breakpoint_line
 187
 188         regsub -all {\.|/} $filename {} temp
 189         set win .text$temp
 190         text $win -height 25 -width 80 -relief raised -borderwidth 2 -yscrollcommand textscrollproc -setgrid true -cursor hand2
 191         bind $win <Enter> {focus %W}
 192 #       bind $win <1> {breakpoint_menu %W %X %Y %x %y}
 193         bind $win <B1-Motion> do_nothing
 194         bind $win n {gdb_cmd next ; update_ptr}
 195         bind $win s {gdb_cmd step ; update_ptr}
 196         bind $win c {gdb_cmd continue ; update_ptr}
 197         bind $win f {gdb_cmd finish ; update_ptr}
 198         bind $win u {gdb_cmd up ; update_ptr}
 199         bind $win d {gdb_cmd down ; update_ptr}
 200         set fh [open $filename]
 201         $win delete 0.0 end
 202         $win insert 0.0 [read $fh]
 203         close $fh
 204         set numlines [$win index end]
 205         set numlines [lindex [split $numlines .] 0]
 206         for {set i 1} {$i <= $numlines} {incr i} {
 207                 $win insert $i.0 [format "   %4d " $i]
 208                 }
 209
 210         $win tag add wholebuf 0.0 end
 211         $win tag bind wholebuf <1> {breakpoint_menu %W %X %Y %x %y}
 212         foreach bpnum [array names breakpoint_file] {
 213                 if {$breakpoint_file($bpnum) == $filename} {
 214                         insert_breakpoint_tag $win $breakpoint_line($bpnum)
 215                         }
 216                 }
 217
 218         $win configure -state disabled
 219         return $win
 220 }
 221
 222 proc update_listing {linespec} {
 223         global pointers
 224         global screen_height
 225         global screen_top
 226         global screen_bot
 227         global wins cfile
 228         global current_label
 229         global win_to_file
 230         global file_to_debug_file
 231
 232         set line [lindex $linespec 3]
 233         set filename [lindex $linespec 2]
 234         set funcname [lindex $linespec 1]
 235         set debug_file [lindex $linespec 0]
 236
 237         if {$filename == ""} {set filename Blank}
 238
 239         if {$filename != $cfile} then {
 240                 pack forget $wins($cfile)
 241                 set cfile $filename
 242                 if ![info exists wins($cfile)] then {
 243                         set wins($cfile) [create_file_win $cfile]
 244                         set win_to_file($wins($cfile)) $cfile
 245                         set file_to_debug_file($cfile) $debug_file
 246                         set pointers($cfile) 1.1
 247                         }
 248
 249                 pack $wins($cfile) -side left -expand yes -in .listing -fill both -after .label
 250                 $wins($cfile) yview [expr $line - $screen_height / 2]
 251                 }
 252
 253         if {$current_label != "$filename.$funcname"} then {
 254                 set tail [expr [string last / $filename] + 1]
 255                 .label configure -text "[string range $filename $tail end] : ${funcname}()"
 256                 set current_label $filename.$funcname
 257                 }
 258
 259         if [info exists pointers($cfile)] then {
 260                 $wins($cfile) configure -state normal
 261                 set pointer_pos $pointers($cfile)
 262                 $wins($cfile) configure -state normal
 263                 $wins($cfile) delete $pointer_pos
 264                 $wins($cfile) insert $pointer_pos " "
 265
 266                 set pointer_pos [$wins($cfile) index $line.1]
 267                 set pointers($cfile) $pointer_pos
 268
 269                 $wins($cfile) delete $pointer_pos
 270                 $wins($cfile) insert $pointer_pos "\xbb"
 271
 272                 if {$line < $screen_top + 1
 273                     || $line > $screen_bot} then {
 274                         $wins($cfile) yview [expr $line - $screen_height / 2]
 275                         }
 276
 277                 $wins($cfile) configure -state disabled
 278                 }
 279 }
 280
 281 proc update_ptr {} {update_listing [gdb_loc]}
 282
 283 # Setup listing window
 284
 285 frame .listing
 286
 287 wm minsize . 1 1
 288
 289 label .label -text "*No file*" -borderwidth 2 -relief raised
 290 text $wins($cfile) -height 25 -width 80 -relief raised -borderwidth 2 -yscrollcommand textscrollproc -setgrid true -cursor hand2
 291 scrollbar .scroll -orient vertical -command {$wins($cfile) yview}
 292
 293 if {[tk colormodel .text] == "color"} {
 294         set highlight "-background red2 -borderwidth 2 -relief sunk"
 295 } else {
 296         set fg [lindex [.text config -foreground] 4]
 297         set bg [lindex [.text config -background] 4]
 298         set highlight "-foreground $bg -background $fg -borderwidth 0"
 299 }
 300
 301 proc textscrollproc {args} {global screen_height screen_top screen_bot
 302                             eval ".scroll set $args"
 303                             set screen_height [lindex $args 1]
 304                             set screen_top [lindex $args 2]
 305                             set screen_bot [lindex $args 3]}
 306
 307 $wins($cfile) insert 0.0 "  This page intentionally left blank."
 308 $wins($cfile) configure -state disabled
 309
 310 pack .label -side bottom -fill x -in .listing
 311 pack $wins($cfile) -side left -expand yes -in .listing -fill both
 312 pack .scroll -side left -fill y -in .listing
 313
 314 button .start -text Start -command \
 315         {gdb_cmd {break main}
 316          gdb_cmd {enable delete $bpnum}
 317          gdb_cmd run
 318          update_ptr }
 319 button .step -text Step -command {gdb_cmd step ; update_ptr}
 320 button .next -text Next -command {gdb_cmd next ; update_ptr}
 321 button .continue -text Continue -command {gdb_cmd continue ; update_ptr}
 322 button .finish -text Finish -command {gdb_cmd finish ; update_ptr}
 323 #button .test -text Test -command {echo [info var]}
 324 button .exit -text Exit -command {gdb_cmd quit}
 325 button .up -text Up -command {gdb_cmd up ; update_ptr}
 326 button .down -text Down -command {gdb_cmd down ; update_ptr}
 327 button .bottom -text "Bottom" -command {gdb_cmd {frame 0} ; update_ptr}
 328
 329 proc files_command {} {
 330         toplevel .files_window
 331
 332         wm minsize .files_window 1 1
 333 #       wm overrideredirect .files_window true
 334         listbox .files_window.list -geometry 30x20 -setgrid true
 335         button .files_window.close -text Close -command {destroy .files_window}
 336         tk_listboxSingleSelect .files_window.list
 337         eval .files_window.list insert 0 [lsort [gdb_listfiles]]
 338         pack .files_window.list -side top -fill both -expand yes
 339         pack .files_window.close -side bottom -fill x -expand no -anchor s
 340         bind .files_window.list <Any-ButtonRelease-1> {
 341                 set file [%W get [%W curselection]]
 342                 gdb_cmd "list $file:1,0"
 343                 update_listing [gdb_loc $file:1]
 344                 destroy .files_window}
 345 }
 346
 347 button .files -text Files -command files_command
 348
 349 pack .listing -side bottom -fill both -expand yes
 350 #pack .test -side bottom -fill x
 351 pack .start .step .next .continue .finish .up .down .bottom .files .exit -side left
 352 toplevel .command
 353
 354 # Setup command window
 355
 356 label .command.label -text "* Command Buffer *" -borderwidth 2 -relief raised
 357 text .command.text -height 25 -width 80 -relief raised -borderwidth 2 -setgrid true -cursor hand2
 358
 359 pack .command.label -side top -fill x
 360 pack .command.text -side top -expand yes -fill both
 361
 362 set command_line {}
 363
 364 gdb_cmd {set language c}
 365 gdb_cmd {set height 0}
 366 gdb_cmd {set width 0}
 367
 368 bind .command.text <Any-Key> {
 369         global command_line
 370
 371         %W insert end %A
 372         %W yview -pickplace end
 373         append command_line %A
 374         }
 375 bind .command.text <Key-Return> {
 376         global command_line
 377
 378         %W insert end \n
 379         %W yview -pickplace end
 380         gdb_cmd $command_line
 381         set command_line {}
 382         update_ptr
 383         %W insert end "(gdb) "
 384         %W yview -pickplace end
 385         }
 386 bind .command.text <Enter> {focus %W}
 387 bind .command.text <Delete> {delete_char %W}
 388 bind .command.text <BackSpace> {delete_char %W}
 389 proc delete_char {win} {
 390         global command_line
 391
 392         tk_textBackspace $win
 393         $win yview -pickplace insert
 394         set tmp [expr [string length $command_line] - 2]
 395         set command_line [string range $command_line 0 $tmp]
 396 }
 397
 398 wm minsize .command 1 1
 399