Commit | Line | Data |
---|---|---|
754e5da2 SG |
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 |