1 # GDB GUI setup for GDB, the GNU debugger.
3 # Free Software Foundation, Inc.
5 # Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
7 # This file is part of GDB.
9 # This program is free software; you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 2 of the License, or
12 # (at your option) any later version.
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with this program; if not, write to the Free Software
21 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
24 set wins
($cfile) .src.
text
31 set breakpoint_file
(-1) {[garbage
]}
32 set disassemble_with_source nosource
33 set expr_update_list
(0) 0
35 #option add *Foreground Black
36 #option add *Background White
37 #option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1
38 tk colormodel . monochrome
40 proc echo
string {puts stdout
$string}
42 if [info exists env
(EDITOR
)] then
{
43 set editor
$env(EDITOR
)
50 # These functions are called by GDB (from C code) to do various things in
51 # TK-land. All start with the prefix `gdbtk_tcl_' to make them easy to find.
57 # gdbtk_tcl_fputs (text) - Output text to the command window
61 # GDB calls this to output TEXT to the GDB command window. The text is
62 # placed at the end of the text widget. Note that output may not occur,
63 # due to buffering. Use gdbtk_tcl_flush to cause an immediate update.
66 proc gdbtk_tcl_fputs
{arg
} {
67 .cmd.
text insert end
"$arg"
68 .cmd.
text yview
-pickplace end
71 proc gdbtk_tcl_fputs_error
{arg
} {
72 .cmd.
text insert end
"$arg"
73 .cmd.
text yview
-pickplace end
79 # gdbtk_tcl_flush () - Flush output to the command window
83 # GDB calls this to force all buffered text to the GDB command window.
86 proc gdbtk_tcl_flush
{} {
87 .cmd.
text yview
-pickplace end
94 # gdbtk_tcl_query (message) - Create a yes/no query dialog box
98 # GDB calls this to create a yes/no dialog box containing MESSAGE. GDB
99 # is hung while the dialog box is active (ie: no commands will work),
100 # however windows can still be refreshed in case of damage or exposure.
103 proc gdbtk_tcl_query
{message} {
104 tk_dialog .query
"gdb : query" "$message" {} 1 "No" "Yes"
110 # gdbtk_start_variable_annotation (args ...) -
114 # Not yet implemented.
117 proc gdbtk_tcl_start_variable_annotation
{valaddr ref_type stor_cl cum_expr field type_cast
} {
118 echo
"gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
124 # gdbtk_end_variable_annotation (args ...) -
128 # Not yet implemented.
131 proc gdbtk_tcl_end_variable_annotation
{} {
132 echo gdbtk_tcl_end_variable_annotation
138 # gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK
139 # interface of changes to breakpoints.
143 # GDB calls this to notify TK of changes to breakpoints. ACTION is one
145 # create - Notify of breakpoint creation
146 # delete - Notify of breakpoint deletion
147 # modify - Notify of breakpoint modification
150 # file line pc type enabled disposition silent ignore_count commands cond_string thread hit_count
152 proc gdbtk_tcl_breakpoint
{action bpnum
} {
153 set bpinfo
[gdb_get_breakpoint_info
$bpnum]
154 set file [lindex $bpinfo 0]
155 set line
[lindex $bpinfo 1]
156 set pc
[lindex $bpinfo 2]
157 set enable
[lindex $bpinfo 4]
159 if {$action == "modify"} {
160 if {$enable == "1"} {
167 ${action
}_breakpoint
$bpnum $file $line $pc
170 proc create_breakpoints_window
{} {
173 if [winfo exists .breakpoints
] {raise .breakpoints
; return}
175 build_framework .breakpoints
"Breakpoints" ""
177 # First, delete all the old view menu entries
179 .breakpoints.menubar.view.
menu delete
0 last
183 destroy .breakpoints.
label
185 # Replace text with a canvas and fix the scrollbars
187 destroy .breakpoints.
text
188 canvas .breakpoints.c
-relief sunken
-bd 2 \
189 -cursor hand2
-yscrollcommand {.breakpoints.scroll
set}
190 .breakpoints.scroll configure
-command {.breakpoints.c yview
}
191 scrollbar .breakpoints.scrollx
-orient horizontal
\
192 -command {.breakpoints.c xview
} -relief sunken
194 pack .breakpoints.scrollx
-side bottom
-fill x
-in .breakpoints.
info
195 pack .breakpoints.c
-side left
-expand yes
-fill both
\
196 -in .breakpoints.
info
200 # Create a frame for each breakpoint
202 foreach bpnum
[gdb_get_breakpoint_list
] {
203 add_breakpoint_frame
$bpnum
207 # Create a frame for bpnum in the .breakpoints canvas
209 proc add_breakpoint_frame bpnum
{
214 if ![winfo exists .breakpoints
] return
216 set bpinfo
[gdb_get_breakpoint_info
$bpnum]
218 set file [lindex $bpinfo 0]
219 set line
[lindex $bpinfo 1]
220 set pc
[lindex $bpinfo 2]
221 set type
[lindex $bpinfo 3]
222 set enabled
($bpnum) [lindex $bpinfo 4]
223 set disposition
($bpnum) [lindex $bpinfo 5]
224 set silent
[lindex $bpinfo 6]
225 set ignore_count
[lindex $bpinfo 7]
226 set commands
[lindex $bpinfo 8]
227 set cond
[lindex $bpinfo 9]
228 set thread
[lindex $bpinfo 10]
229 set hit_count
[lindex $bpinfo 11]
231 set f .breakpoints.c.
$bpnum
233 if ![winfo exists
$f] {
234 frame $f -relief sunken
-bd 2
236 label $f.id
-text "#$bpnum $file:$line ($pc)" \
237 -relief flat
-bd 2 -anchor w
239 label $f.hit_count.
label -text "Hit count:" -relief flat
\
240 -bd 2 -anchor w
-width 11
241 label $f.hit_count.val
-text $hit_count -relief flat
\
243 checkbutton $f.hit_count.enabled
-text Enabled
\
244 -variable enabled
($bpnum) -anchor w
-relief flat
246 pack $f.hit_count.
label $f.hit_count.val
-side left
247 pack $f.hit_count.enabled
-side right
250 label $f.thread.
label -text "Thread: " -relief flat
-bd 2 \
252 entry $f.thread.
entry -bd 2 -relief sunken
-width 10
253 $f.thread.
entry insert end
$thread
254 pack $f.thread.
label -side left
255 pack $f.thread.
entry -side left
-fill x
258 label $f.cond.
label -text "Condition: " -relief flat
-bd 2 \
260 entry $f.cond.
entry -bd 2 -relief sunken
261 $f.cond.
entry insert end
$cond
262 pack $f.cond.
label -side left
263 pack $f.cond.
entry -side left
-fill x
-expand yes
265 frame $f.ignore_count
266 label $f.ignore_count.
label -text "Ignore count: " \
267 -relief flat
-bd 2 -width 11 -anchor w
268 entry $f.ignore_count.
entry -bd 2 -relief sunken
-width 10
269 $f.ignore_count.
entry insert end
$ignore_count
270 pack $f.ignore_count.
label -side left
271 pack $f.ignore_count.
entry -side left
-fill x
275 label $f.disps.
label -text "Disposition: " -relief flat
-bd 2 \
278 radiobutton $f.disps.delete
-text Delete
\
279 -variable disposition
($bpnum) -anchor w
-relief flat
\
280 -command "gdb_cmd \"delete break $bpnum\""
282 radiobutton $f.disps.disable
-text Disable
\
283 -variable disposition
($bpnum) -anchor w
-relief flat
\
284 -command "gdb_cmd \"disable break $bpnum\""
286 radiobutton $f.disps.donttouch
-text "Leave alone" \
287 -variable disposition
($bpnum) -anchor w
-relief flat
\
288 -command "gdb_cmd \"enable break $bpnum\""
290 pack $f.disps.
label $f.disps.delete
$f.disps.disable
\
291 $f.disps.donttouch
-side left
-anchor w
292 text $f.commands
-relief sunken
-bd 2 -setgrid true
\
293 -cursor hand2
-height 3 -width 30
295 foreach line
$commands {
296 $f.commands insert end
"${line}\n"
299 pack $f.id
-side top
-anchor nw
-fill x
300 pack $f.hit_count
$f.cond
$f.thread
$f.ignore_count
$f.disps
\
301 $f.commands
-side top
-fill x
-anchor nw
304 set tag
[.breakpoints.c create window
0 $bpframe_lasty -window $f -anchor nw
]
306 set bbox
[.breakpoints.c bbox
$tag]
308 set bpframe_lasty
[lindex $bbox 3]
310 .breakpoints.c configure
-width [lindex $bbox 2]
313 # Delete a breakpoint frame
315 proc delete_breakpoint_frame bpnum
{
318 if ![winfo exists .breakpoints
] return
320 # First, clear the canvas
322 .breakpoints.c delete all
324 # Now, repopulate it with all but the doomed breakpoint
327 foreach bp
[gdb_get_breakpoint_list
] {
329 add_breakpoint_frame
$bp
334 proc asm_win_name
{funcname
} {
335 if {$funcname == "*None*"} {return .asm.
text}
337 regsub -all {\.
} $funcname _ temp
339 return .asm.func_
${temp
}
345 # create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
349 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
350 # land of breakpoint creation. This consists of recording the file and
351 # line number in the breakpoint_file and breakpoint_line arrays. Also,
352 # if there is already a window associated with FILE, it is updated with
356 proc create_breakpoint
{bpnum
file line pc
} {
358 global breakpoint_file
359 global breakpoint_line
360 global pos_to_breakpoint
361 global pos_to_bpcount
365 # Record breakpoint locations
367 set breakpoint_file
($bpnum) $file
368 set breakpoint_line
($bpnum) $line
369 set pos_to_breakpoint
($file:$line) $bpnum
370 if ![info exists pos_to_bpcount
($file:$line)] {
371 set pos_to_bpcount
($file:$line) 0
373 incr pos_to_bpcount
($file:$line)
374 set pos_to_breakpoint
($pc) $bpnum
375 if ![info exists pos_to_bpcount
($pc)] {
376 set pos_to_bpcount
($pc) 0
378 incr pos_to_bpcount
($pc)
380 # If there's a window for this file, update it
382 if [info exists wins
($file)] {
383 insert_breakpoint_tag
$wins($file) $line
386 # If there's an assembly window, update that too
388 set win
[asm_win_name
$cfunc]
389 if [winfo exists
$win] {
390 insert_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
393 # Update the breakpoints window
395 add_breakpoint_frame
$bpnum
401 # delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land
405 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
406 # land of breakpoint destruction. This consists of removing the file and
407 # line number from the breakpoint_file and breakpoint_line arrays. Also,
408 # if there is already a window associated with FILE, the tags are removed
412 proc delete_breakpoint
{bpnum
file line pc
} {
414 global breakpoint_file
415 global breakpoint_line
416 global pos_to_breakpoint
417 global pos_to_bpcount
420 # Save line number and file for later
422 set line
$breakpoint_line($bpnum)
424 set file $breakpoint_file($bpnum)
426 # Reset breakpoint annotation info
428 if {$pos_to_bpcount($file:$line) > 0} {
429 decr pos_to_bpcount
($file:$line)
431 if {$pos_to_bpcount($file:$line) == 0} {
432 catch "unset pos_to_breakpoint($file:$line)"
434 unset breakpoint_file
($bpnum)
435 unset breakpoint_line
($bpnum)
437 # If there's a window for this file, update it
439 if [info exists wins
($file)] {
440 delete_breakpoint_tag
$wins($file) $line
445 # If there's an assembly window, update that too
447 if {$pos_to_bpcount($pc) > 0} {
448 decr pos_to_bpcount
($pc)
450 if {$pos_to_bpcount($pc) == 0} {
451 catch "unset pos_to_breakpoint($pc)"
453 set win
[asm_win_name
$cfunc]
454 if [winfo exists
$win] {
455 delete_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
460 delete_breakpoint_frame
$bpnum
466 # enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
470 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
471 # land of a breakpoint being enabled. This consists of unstippling the
472 # specified breakpoint indicator.
475 proc enable_breakpoint
{bpnum
file line pc
} {
480 if [info exists wins
($file)] {
481 $wins($file) tag configure
$line -fgstipple {}
484 # If there's an assembly window, update that too
486 set win
[asm_win_name
$cfunc]
487 if [winfo exists
$win] {
488 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple {}
491 # If there's a breakpoint window, update that too
493 if [winfo exists .breakpoints
] {
494 set enabled
($bpnum) 1
501 # disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
505 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
506 # land of a breakpoint being disabled. This consists of stippling the
507 # specified breakpoint indicator.
510 proc disable_breakpoint
{bpnum
file line pc
} {
515 if [info exists wins
($file)] {
516 $wins($file) tag configure
$line -fgstipple gray50
519 # If there's an assembly window, update that too
521 set win
[asm_win_name
$cfunc]
522 if [winfo exists
$win] {
523 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple gray50
526 # If there's a breakpoint window, update that too
528 if [winfo exists .breakpoints
] {
529 set enabled
($bpnum) 0
536 # insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN.
540 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a
541 # breakpoint tag into window WIN at line LINE.
544 proc insert_breakpoint_tag
{win line
} {
545 $win configure
-state normal
547 $win insert
$line.0 "B"
548 $win tag add
$line $line.0
549 $win tag add delete
$line.0 "$line.0 lineend"
550 $win tag add margin
$line.0 "$line.0 lineend"
552 $win configure
-state disabled
558 # delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN.
562 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a
563 # breakpoint tag from window WIN at line LINE.
566 proc delete_breakpoint_tag
{win line
} {
567 $win configure
-state normal
569 if {[string range
$win 0 3] == ".src"} then
{
570 $win insert
$line.0 "\xa4"
572 $win insert
$line.0 " "
574 $win tag delete
$line
575 $win tag add delete
$line.0 "$line.0 lineend"
576 $win tag add margin
$line.0 "$line.0 lineend"
577 $win configure
-state disabled
580 proc gdbtk_tcl_busy
{} {
581 if [winfo exists .src
] {
582 .src.start configure
-state disabled
583 .src.stop configure
-state normal
584 .src.step configure
-state disabled
585 .src.next configure
-state disabled
586 .src.
continue configure
-state disabled
587 .src.finish configure
-state disabled
588 .src.up configure
-state disabled
589 .src.down configure
-state disabled
590 .src.bottom configure
-state disabled
592 if [winfo exists .asm
] {
593 .asm.stepi configure
-state disabled
594 .asm.nexti configure
-state disabled
595 .asm.
continue configure
-state disabled
596 .asm.finish configure
-state disabled
597 .asm.up configure
-state disabled
598 .asm.down configure
-state disabled
599 .asm.bottom configure
-state disabled
604 proc gdbtk_tcl_idle
{} {
605 if [winfo exists .src
] {
606 .src.start configure
-state normal
607 .src.stop configure
-state disabled
608 .src.step configure
-state normal
609 .src.next configure
-state normal
610 .src.
continue configure
-state normal
611 .src.finish configure
-state normal
612 .src.up configure
-state normal
613 .src.down configure
-state normal
614 .src.bottom configure
-state normal
617 if [winfo exists .asm
] {
618 .asm.stepi configure
-state normal
619 .asm.nexti configure
-state normal
620 .asm.
continue configure
-state normal
621 .asm.finish configure
-state normal
622 .asm.up configure
-state normal
623 .asm.down configure
-state normal
624 .asm.bottom configure
-state normal
632 # decr (var val) - compliment to incr
637 proc decr
{var
{val
1}} {
639 set num
[expr $num - $val]
646 # pc_to_line (pclist pc) - convert PC to a line number.
650 # Convert PC to a line number from PCLIST. If exact line isn't found,
651 # we return the first line that starts before PC.
653 proc pc_to_line
{pclist pc
} {
654 set line
[lsearch -exact $pclist $pc]
656 if {$line >= 1} { return $line }
659 foreach linepc
[lrange $pclist 1 end
] {
660 if {$pc < $linepc} { decr line
; return $line }
663 return [expr $line - 1]
669 # file popup menu - Define the file popup menu.
673 # This menu just contains a bunch of buttons that do various things to
674 # the line under the cursor.
678 # Edit - Run the editor (specified by the environment variable EDITOR) on
679 # this file, at the current line.
680 # Breakpoint - Set a breakpoint at the current line. This just shoves
681 # a `break' command at GDB with the appropriate file and line
682 # number. Eventually, GDB calls us back (at gdbtk_tcl_breakpoint)
683 # to notify us of where the breakpoint needs to show up.
686 menu .file_popup
-cursor hand2
687 .file_popup add command
-label "Not yet set" -state disabled
688 .file_popup add separator
689 .file_popup add command
-label "Edit" -command {exec $editor +$selected_line $selected_file &}
690 .file_popup add command
-label "Set breakpoint" -command {gdb_cmd
"break $selected_file:$selected_line"}
692 # Use this procedure to get the GDB core to execute the string `cmd'. This is
693 # a wrapper around gdb_cmd, which will catch errors, and send output to the
694 # command window. It will also cause all of the other windows to be updated.
696 proc interactive_cmd
{cmd
} {
697 catch {gdb_cmd
"$cmd"} result
698 .cmd.
text insert end
$result
699 .cmd.
text yview
-pickplace end
706 # file popup menu - Define the file popup menu bindings.
710 # This defines the binding for the file popup menu. Currently, there is
711 # only one, which is activated when Button-1 is released. This causes
712 # the menu to be unposted, releases the grab for the menu, and then
713 # unhighlights the line under the cursor. After that, the selected menu
717 bind .file_popup
<Any-ButtonRelease-1
> {
720 # First, remove the menu, and release the pointer
723 grab release .file_popup
725 # Unhighlight the selected line
727 $selected_win tag delete breaktag
729 # Actually invoke the menubutton here!
737 # file_popup_menu (win x y xrel yrel) - Popup the file popup menu.
741 # This procedure is invoked as a result of a command binding in the
742 # listing window. It does several things:
743 # o - It highlights the line under the cursor.
744 # o - It pops up the file popup menu which is intended to do
745 # various things to the aforementioned line.
746 # o - Grabs the mouse for the file popup menu.
749 # Button 1 has been pressed in a listing window. Pop up a menu.
751 proc file_popup_menu
{win x y xrel yrel
} {
754 global file_to_debug_file
760 # Map TK window name back to file name.
762 set file $win_to_file($win)
764 set pos
[$win index
@$xrel,$yrel]
766 # Record selected file and line for menu button actions
768 set selected_file
$file_to_debug_file($file)
769 set selected_line
[lindex [split $pos .
] 0]
770 set selected_win
$win
772 # Highlight the selected line
774 eval $win tag config breaktag
$highlight
775 $win tag add breaktag
"$pos linestart" "$pos linestart + 1l"
777 # Post the menu near the pointer, (and grab it)
779 .file_popup entryconfigure
0 -label "$selected_file:$selected_line"
780 .file_popup post
[expr $x-[winfo width .file_popup
]/2] [expr $y-10]
787 # listing_window_button_1 (win x y xrel yrel) - Handle button 1 in listing window
791 # This procedure is invoked as a result of holding down button 1 in the
792 # listing window. The action taken depends upon where the button was
793 # pressed. If it was in the left margin (the breakpoint column), it
794 # sets or clears a breakpoint. In the main text area, it will pop up a
798 proc listing_window_button_1
{win x y xrel yrel
} {
801 global file_to_debug_file
806 global pos_to_breakpoint
808 # Map TK window name back to file name.
810 set file $win_to_file($win)
812 set pos
[split [$win index
@$xrel,$yrel] .
]
814 # Record selected file and line for menu button actions
816 set selected_file
$file_to_debug_file($file)
817 set selected_line
[lindex $pos 0]
818 set selected_col
[lindex $pos 1]
819 set selected_win
$win
821 # If we're in the margin, then toggle the breakpoint
823 if {$selected_col < 8} {
824 set pos_break
$selected_file:$selected_line
825 set pos
$file:$selected_line
826 set tmp pos_to_breakpoint
($pos)
827 if [info exists
$tmp] {
829 gdb_cmd
"delete $bpnum"
831 gdb_cmd
"break $pos_break"
836 # Post the menu near the pointer, (and grab it)
838 .file_popup entryconfigure
0 -label "$selected_file:$selected_line"
839 .file_popup post
[expr $x-[winfo width .file_popup
]/2] [expr $y-10]
846 # asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window
850 # This procedure is invoked as a result of holding down button 1 in the
851 # assembly window. The action taken depends upon where the button was
852 # pressed. If it was in the left margin (the breakpoint column), it
853 # sets or clears a breakpoint. In the main text area, it will pop up a
857 proc asm_window_button_1
{win x y xrel yrel
} {
860 global file_to_debug_file
865 global pos_to_breakpoint
869 set pos
[split [$win index
@$xrel,$yrel] .
]
871 # Record selected file and line for menu button actions
873 set selected_line
[lindex $pos 0]
874 set selected_col
[lindex $pos 1]
875 set selected_win
$win
879 set pc
[lindex $pclist($cfunc) $selected_line]
881 # If we're in the margin, then toggle the breakpoint
883 if {$selected_col < 11} {
884 set tmp pos_to_breakpoint
($pc)
885 if [info exists
$tmp] {
887 gdb_cmd
"delete $bpnum"
894 # Post the menu near the pointer, (and grab it)
896 # .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
897 # .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
904 # do_nothing - Does absolutely nothing.
908 # This procedure does nothing. It is used as a placeholder to allow
909 # the disabling of bindings that would normally be inherited from the
910 # parent widget. I can't think of any other way to do this.
913 proc do_nothing
{} {}
918 # not_implemented_yet - warn that a feature is unavailable
922 # This procedure warns that something doesn't actually work yet.
925 proc not_implemented_yet
{message} {
926 tk_dialog .unimpl
"gdb : unimpl" \
927 "$message: not implemented in the interface yet" \
934 # create_expr_window - Create expression display window
938 # Create the expression display window.
943 proc add_expr
{expr} {
944 global expr_update_list
949 set e .
expr.e
${expr_num
}
953 checkbutton $e.
update -text " " -relief flat
\
954 -variable expr_update_list
($expr_num)
955 text $e.
expr -width 20 -height 1
956 $e.
expr insert
0.0 $expr
957 bind $e.
expr <1> "update_expr $expr_num"
958 text $e.val
-width 20 -height 1
960 update_expr
$expr_num
962 pack $e.
update -side left
-anchor nw
963 pack $e.
expr $e.val
-side left
-expand yes
-fill x
965 pack $e -side top
-fill x
-anchor w
968 set delete_expr_flag
0
972 proc delete_expr
{} {
973 global delete_expr_flag
975 if {$delete_expr_flag == 1} {
976 set delete_expr_flag
0
977 tk_butUp .
expr.delete
978 bind .
expr.delete
<Any-Leave
> {}
980 set delete_expr_flag
1
981 bind .
expr.delete
<Any-Leave
> do_nothing
982 tk_butDown .
expr.delete
986 proc update_expr
{expr_num
} {
987 global delete_expr_flag
988 global expr_update_list
990 set e .
expr.e
${expr_num
}
992 if {$delete_expr_flag == 1} {
993 set delete_expr_flag
0
995 tk_butUp .
expr.delete
996 tk_butLeave .
expr.delete
997 bind .
expr.delete
<Any-Leave
> {}
998 unset expr_update_list
($expr_num)
1002 set expr [$e.
expr get
0.0 end
]
1004 $e.val delete
0.0 end
1005 if [catch "gdb_eval $expr" val
] {
1008 $e.val insert
0.0 $val
1012 proc update_exprs
{} {
1013 global expr_update_list
1015 foreach expr_num
[array names expr_update_list
] {
1016 if $expr_update_list($expr_num) {
1017 update_expr
$expr_num
1022 proc create_expr_window
{} {
1024 if [winfo exists .
expr] {raise .
expr ; return}
1027 wm minsize .
expr 1 1
1028 wm title .
expr Expression
1029 wm iconname .
expr "Reg config"
1031 frame .
expr.entryframe
1033 entry .
expr.
entry -borderwidth 2 -relief sunken
1034 bind .
expr <Enter
> {focus .
expr.
entry}
1035 bind .
expr.
entry <Key-Return
> {add_expr
[.
expr.
entry get
]
1036 .
expr.
entry delete
0 end
}
1038 label .
expr.entrylab
-text "Expression: "
1040 pack .
expr.entrylab
-in .
expr.entryframe
-side left
1041 pack .
expr.
entry -in .
expr.entryframe
-side left
-fill x
-expand yes
1045 button .
expr.delete
-text Delete
1046 bind .
expr.delete
<1> delete_expr
1048 button .
expr.
close -text Close
-command {destroy .
expr}
1050 pack .
expr.delete
-side left
-fill x
-expand yes
-in .
expr.buts
1051 pack .
expr.
close -side right
-fill x
-expand yes
-in .
expr.buts
1053 pack .
expr.buts
-side bottom
-fill x
1054 pack .
expr.entryframe
-side bottom
-fill x
1058 label .
expr.updlab
-text Update
1059 label .
expr.exprlab
-text Expression
1060 label .
expr.vallab
-text Value
1062 pack .
expr.updlab
-side left
-in .
expr.labels
1063 pack .
expr.exprlab .
expr.vallab
-side left
-in .
expr.labels
-expand yes
-anchor w
1065 pack .
expr.labels
-side top
-fill x
-anchor w
1071 # display_expression (expression) - Display EXPRESSION in display window
1075 # Display EXPRESSION and its value in the expression display window.
1078 proc display_expression
{expression
} {
1081 add_expr
$expression
1087 # create_file_win (filename) - Create a win for FILENAME.
1091 # The new text widget.
1095 # This procedure creates a text widget for FILENAME. It returns the
1096 # newly created widget. First, a text widget is created, and given basic
1097 # configuration info. Second, all the bindings are setup. Third, the
1098 # file FILENAME is read into the text widget. Fourth, margins and line
1099 # numbers are added.
1102 proc create_file_win
{filename debug_file
} {
1103 global breakpoint_file
1104 global breakpoint_line
1107 # Replace all the dirty characters in $filename with clean ones, and generate
1108 # a unique name for the text widget.
1110 regsub -all {\.
} $filename {} temp
1111 set win .src.
text$temp
1113 # Open the file, and read it into the text widget
1115 if [catch "open $filename" fh
] {
1116 # File can't be read. Put error message into .src.nofile window and return.
1118 catch {destroy .src.nofile
}
1119 text .src.nofile
-height 25 -width 88 -relief sunken
\
1120 -borderwidth 2 -yscrollcommand textscrollproc
\
1121 -setgrid true
-cursor hand2
1122 .src.nofile insert
0.0 $fh
1123 .src.nofile configure
-state disabled
1124 bind .src.nofile
<1> do_nothing
1125 bind .src.nofile
<B1-Motion
> do_nothing
1129 # Actually create and do basic configuration on the text widget.
1131 text $win -height 25 -width 88 -relief sunken
-borderwidth 2 \
1132 -yscrollcommand textscrollproc
-setgrid true
-cursor hand2
1134 # Setup all the bindings
1136 bind $win <Enter
> {focus %W
}
1137 bind $win <1> do_nothing
1138 bind $win <B1-Motion
> do_nothing
1140 bind $win <Key-Alt_R
> do_nothing
1141 bind $win <Key-Alt_L
> do_nothing
1142 bind $win <Key-Prior
> "$win yview {@0,0 - 10 lines}"
1143 bind $win <Key-Next
> "$win yview {@0,0 + 10 lines}"
1144 bind $win <Key-Up
> "$win yview {@0,0 - 1 lines}"
1145 bind $win <Key-Down
> "$win yview {@0,0 + 1 lines}"
1146 bind $win <Key-Home
> {update_listing
[gdb_loc
]}
1147 bind $win <Key-End
> "$win yview -pickplace end"
1149 bind $win n
{interactive_cmd next
}
1150 bind $win s
{interactive_cmd step
}
1151 bind $win c
{interactive_cmd
continue}
1152 bind $win f
{interactive_cmd finish
}
1153 bind $win u
{interactive_cmd up
}
1154 bind $win d
{interactive_cmd down
}
1157 $win insert
0.0 [read $fh]
1160 # Add margins (for annotations) and a line number to each line (if requested)
1162 set numlines
[$win index end
]
1163 set numlines
[lindex [split $numlines .
] 0]
1165 for {set i
1} {$i <= $numlines} {incr i
} {
1166 $win insert
$i.0 [format " %4d " $i]
1167 $win tag add
source $i.8 "$i.0 lineend"
1170 for {set i
1} {$i <= $numlines} {incr i
} {
1171 $win insert
$i.0 " "
1172 $win tag add
source $i.8 "$i.0 lineend"
1178 foreach i
[gdb_sourcelines
$debug_file] {
1180 $win insert
$i.0 "\xa4"
1181 $win tag add margin
$i.0 $i.8
1184 $win tag
bind margin
<1> {listing_window_button_1
%W
%X
%Y
%x
%y
}
1185 $win tag
bind source <1> {
1186 %W mark
set anchor
"@%x,%y wordstart"
1187 set last
[%W index
"@%x,%y wordend"]
1188 %W tag remove sel
0.0 anchor
1189 %W tag remove sel
$last end
1190 %W tag add sel anchor
$last
1192 # $win tag bind source <Double-Button-1> {
1193 # %W mark set anchor "@%x,%y wordstart"
1194 # set last [%W index "@%x,%y wordend"]
1195 # %W tag remove sel 0.0 anchor
1196 # %W tag remove sel $last end
1197 # %W tag add sel anchor $last
1198 # echo "Selected [selection get]"
1200 $win tag
bind source <B1-Motion
> {
1201 %W tag remove sel
0.0 anchor
1202 %W tag remove sel
$last end
1203 %W tag add sel anchor
@%x
,%y
1205 $win tag
bind sel
<1> do_nothing
1206 $win tag
bind sel
<Double-Button-1
> {display_expression
[selection get
]}
1210 # Scan though the breakpoint data base and install any destined for this file
1212 foreach bpnum
[array names breakpoint_file
] {
1213 if {$breakpoint_file($bpnum) == $filename} {
1214 insert_breakpoint_tag
$win $breakpoint_line($bpnum)
1218 # Disable the text widget to prevent user modifications
1220 $win configure
-state disabled
1227 # create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
1231 # The new text widget.
1235 # This procedure creates a text widget for FUNCNAME. It returns the
1236 # newly created widget. First, a text widget is created, and given basic
1237 # configuration info. Second, all the bindings are setup. Third, the
1238 # function FUNCNAME is read into the text widget.
1241 proc create_asm_win
{funcname pc
} {
1242 global breakpoint_file
1243 global breakpoint_line
1245 global disassemble_with_source
1247 # Replace all the dirty characters in $filename with clean ones, and generate
1248 # a unique name for the text widget.
1250 set win
[asm_win_name
$funcname]
1252 # Actually create and do basic configuration on the text widget.
1254 text $win -height 25 -width 80 -relief sunken
-borderwidth 2 \
1255 -setgrid true
-cursor hand2
-yscrollcommand asmscrollproc
1257 # Setup all the bindings
1259 bind $win <Enter
> {focus %W
}
1260 bind $win <1> {asm_window_button_1
%W
%X
%Y
%x
%y
}
1261 bind $win <B1-Motion
> do_nothing
1263 bind $win <Key-Alt_R
> do_nothing
1264 bind $win <Key-Alt_L
> do_nothing
1265 bind $win <Key-Prior
> "$win yview {@0,0 - 10 lines}"
1266 bind $win <Key-Next
> "$win yview {@0,0 + 10 lines}"
1267 bind $win <Key-Up
> "$win yview {@0,0 - 1 lines}"
1268 bind $win <Key-Down
> "$win yview {@0,0 + 1 lines}"
1269 bind $win <Key-Home
> {update_assembly
[gdb_loc
]}
1270 bind $win <Key-End
> "$win yview -pickplace end"
1272 bind $win n
{interactive_cmd nexti
}
1273 bind $win s
{interactive_cmd stepi
}
1274 bind $win c
{interactive_cmd
continue}
1275 bind $win f
{interactive_cmd finish
}
1276 bind $win u
{interactive_cmd up
}
1277 bind $win d
{interactive_cmd down
}
1279 # Disassemble the code, and read it into the new text widget
1281 $win insert end
[gdb_disassemble
$disassemble_with_source $pc]
1283 set numlines
[$win index end
]
1284 set numlines
[lindex [split $numlines .
] 0]
1287 # Delete the first and last lines, cuz these contain useless info
1289 # $win delete 1.0 2.0
1290 # $win delete {end - 1 lines} end
1293 # Add margins (for annotations) and note the PC for each line
1295 catch "unset pclist($funcname)"
1296 lappend pclist
($funcname) Unused
1297 for {set i
1} {$i <= $numlines} {incr i
} {
1298 scan [$win get
$i.0 "$i.0 lineend"] "%s " pc
1299 lappend pclist
($funcname) $pc
1300 $win insert
$i.0 " "
1303 # Scan though the breakpoint data base and install any destined for this file
1305 # foreach bpnum [array names breakpoint_file] {
1306 # if {$breakpoint_file($bpnum) == $filename} {
1307 # insert_breakpoint_tag $win $breakpoint_line($bpnum)
1311 # Disable the text widget to prevent user modifications
1313 $win configure
-state disabled
1320 # asmscrollproc (WINHEIGHT SCREENHEIGHT SCREENTOP SCREENBOT) - Update the
1321 # asm window scrollbar.
1325 # This procedure is called to update the assembler window's scrollbar.
1328 proc asmscrollproc
{args
} {
1329 global asm_screen_height asm_screen_top asm_screen_bot
1331 eval ".asm.scroll set $args"
1332 set asm_screen_height
[lindex $args 1]
1333 set asm_screen_top
[lindex $args 2]
1334 set asm_screen_bot
[lindex $args 3]
1340 # update_listing (linespec) - Update the listing window according to
1345 # This procedure is called from various places to update the listing
1346 # window based on LINESPEC. It is usually invoked with the result of
1349 # It will move the cursor, and scroll the text widget if necessary.
1350 # Also, it will switch to another text widget if necessary, and update
1351 # the label widget too.
1353 # LINESPEC is a list of the form:
1355 # { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
1357 # DEBUG_FILE - is the abbreviated form of the file name. This is usually
1358 # the file name string given to the cc command. This is
1359 # primarily needed for breakpoint commands, and when an
1360 # abbreviated for of the filename is desired.
1361 # FUNCNAME - is the name of the function.
1362 # FILENAME - is the fully qualified (absolute) file name. It is usually
1363 # the same as $PWD/$DEBUG_FILE, where PWD is the working dir
1364 # at the time the cc command was given. This is used to
1365 # actually locate the file to be displayed.
1366 # LINE - The line number to be displayed.
1368 # Usually, this procedure will just move the cursor one line down to the
1369 # next line to be executed. However, if the cursor moves out of range
1370 # or into another file, it will scroll the text widget so that the line
1371 # of interest is in the middle of the viewable portion of the widget.
1374 proc update_listing
{linespec
} {
1376 global screen_height
1380 global current_label
1382 global file_to_debug_file
1385 # Rip the linespec apart
1387 set line
[lindex $linespec 3]
1388 set filename [lindex $linespec 2]
1389 set funcname
[lindex $linespec 1]
1390 set debug_file
[lindex $linespec 0]
1392 # Sometimes there's no source file for this location
1394 if {$filename == ""} {set filename Blank
}
1396 # If we want to switch files, we need to unpack the current text widget, and
1397 # stick in the new one.
1399 if {$filename != $cfile} then
{
1400 pack forget
$wins($cfile)
1403 # Create a text widget for this file if necessary
1405 if ![info exists wins
($cfile)] then
{
1406 set wins
($cfile) [create_file_win
$cfile $debug_file]
1407 if {$wins($cfile) != ".src.nofile"} {
1408 set win_to_file
($wins($cfile)) $cfile
1409 set file_to_debug_file
($cfile) $debug_file
1410 set pointers
($cfile) 1.1
1414 # Pack the text widget into the listing widget, and scroll to the right place
1416 pack $wins($cfile) -side left
-expand yes
-in .src.
info \
1417 -fill both
-after .src.scroll
1419 # Make the scrollbar point at the new text widget
1421 .src.scroll configure
-command "$wins($cfile) yview"
1423 $wins($cfile) yview
[expr $line - $screen_height / 2]
1426 # Update the label widget in case the filename or function name has changed
1428 if {$current_label != "$filename.$funcname"} then
{
1429 set tail
[expr [string last
/ $filename] + 1]
1430 set .src.
label "[string range $filename $tail end] : ${funcname}()"
1431 # .src.label configure -text "[string range $filename $tail end] : ${funcname}()"
1432 set current_label
$filename.
$funcname
1435 # Update the pointer, scrolling the text widget if necessary to keep the
1436 # pointer in an acceptable part of the screen.
1438 if [info exists pointers
($cfile)] then
{
1439 $wins($cfile) configure
-state normal
1440 set pointer_pos
$pointers($cfile)
1441 $wins($cfile) configure
-state normal
1442 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1443 $wins($cfile) insert
$pointer_pos " "
1445 set pointer_pos
[$wins($cfile) index
$line.1]
1446 set pointers
($cfile) $pointer_pos
1448 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1449 $wins($cfile) insert
$pointer_pos "->"
1451 if {$line < $screen_top + 1
1452 ||
$line > $screen_bot} then
{
1453 $wins($cfile) yview
[expr $line - $screen_height / 2]
1456 $wins($cfile) configure
-state disabled
1463 # create_asm_window - Open up the assembly window.
1467 # Create an assembly window if it doesn't exist.
1470 proc create_asm_window
{} {
1473 if [winfo exists .asm
] {raise .asm
; return}
1476 set win
[asm_win_name
$cfunc]
1478 build_framework .asm Assembly
"*NIL*"
1480 # First, delete all the old menu entries
1482 .asm.menubar.view.
menu delete
0 last
1484 .asm.
text configure
-yscrollcommand asmscrollproc
1489 button .asm.stepi
-width 6 -text Stepi
\
1490 -command {interactive_cmd stepi
}
1491 button .asm.nexti
-width 6 -text Nexti
\
1492 -command {interactive_cmd nexti
}
1493 button .asm.
continue -width 6 -text Cont
\
1494 -command {interactive_cmd
continue}
1495 button .asm.finish
-width 6 -text Finish
\
1496 -command {interactive_cmd finish
}
1497 button .asm.up
-width 6 -text Up
-command {interactive_cmd up
}
1498 button .asm.down
-width 6 -text Down
\
1499 -command {interactive_cmd down
}
1500 button .asm.bottom
-width 6 -text Bottom
\
1501 -command {interactive_cmd
{frame 0}}
1503 pack .asm.stepi .asm.
continue .asm.up .asm.bottom
-side left
-padx 3 -pady 5 -in .asm.row1
1504 pack .asm.nexti .asm.finish .asm.down
-side left
-padx 3 -pady 5 -in .asm.row2
1506 pack .asm.row2 .asm.row1
-side bottom
-anchor w
-before .asm.
info
1510 update_assembly
[gdb_loc
]
1512 # We do this update_assembly to get the proper value of disassemble-from-exec.
1514 # exec file menu item
1515 .asm.menubar.view.
menu add
radiobutton -label "Exec file" \
1516 -variable disassemble-from-exec
-value 1
1517 # target memory menu item
1518 .asm.menubar.view.
menu add
radiobutton -label "Target memory" \
1519 -variable disassemble-from-exec
-value 0
1521 # Disassemble with source
1522 .asm.menubar.view.
menu add
checkbutton -label "Source" \
1523 -variable disassemble_with_source
-onvalue source \
1524 -offvalue nosource
-command {
1525 foreach asm
[info command .asm.func_
*] {
1529 update_assembly
[gdb_loc
]
1533 proc reg_config_menu
{} {
1534 catch {destroy .reg.config
}
1535 toplevel .reg.config
1536 wm geometry .reg.config
+300+300
1537 wm title .reg.config
"Register configuration"
1538 wm iconname .reg.config
"Reg config"
1539 set regnames
[gdb_regnames
]
1540 set num_regs
[llength $regnames]
1542 frame .reg.config.buts
1544 button .reg.config.done
-text " Done " -command "
1545 recompute_reg_display_list $num_regs
1547 update_registers all
1548 destroy .reg.config "
1550 button .reg.config.
update -text Update
-command "
1551 recompute_reg_display_list $num_regs
1553 update_registers all "
1555 pack .reg.config.buts
-side bottom
-fill x
1557 pack .reg.config.done
-side left
-fill x
-expand yes
-in .reg.config.buts
1558 pack .reg.config.
update -side right
-fill x
-expand yes
-in .reg.config.buts
1560 # Since there can be lots of registers, we build the window with no more than
1561 # 32 rows, and as many columns as needed.
1563 # First, figure out how many columns we need and create that many column frame
1566 set ncols
[expr ($num_regs + 31) / 32]
1568 for {set col
0} {$col < $ncols} {incr col
} {
1569 frame .reg.config.col
$col
1570 pack .reg.config.col
$col -side left
-anchor n
1573 # Now, create the checkbutton widgets and pack them in the appropriate columns
1577 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1578 set regname
[lindex $regnames $regnum]
1579 checkbutton .reg.config.col
$col.
$row -text $regname -pady 0 \
1580 -variable regena
($regnum) -relief flat
-anchor w
-bd 1
1582 pack .reg.config.col
$col.
$row -side top
-fill both
1595 # create_registers_window - Open up the register display window.
1599 # Create the register display window, with automatic updates.
1602 proc create_registers_window
{} {
1605 if [winfo exists .reg
] {raise .reg
; return}
1607 # Create an initial register display list consisting of all registers
1609 if ![info exists reg_format
] {
1610 global reg_display_list
1611 global changed_reg_list
1615 set num_regs
[llength [gdb_regnames
]]
1616 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1617 set regena
($regnum) 1
1619 recompute_reg_display_list
$num_regs
1620 set changed_reg_list
$reg_display_list
1623 build_framework .reg Registers
1625 # First, delete all the old menu entries
1627 .reg.menubar.view.
menu delete
0 last
1630 .reg.menubar.view.
menu add
radiobutton -label Hex
\
1631 -command {set reg_format x
; update_registers all
}
1634 .reg.menubar.view.
menu add
radiobutton -label Decimal
\
1635 -command {set reg_format d
; update_registers all
}
1638 .reg.menubar.view.
menu add
radiobutton -label Octal
\
1639 -command {set reg_format o
; update_registers all
}
1642 .reg.menubar.view.
menu add
radiobutton -label Natural
\
1643 -command {set reg_format
{} ; update_registers all
}
1646 .reg.menubar.view.
menu add separator
1648 .reg.menubar.view.
menu add command
-label Config
-command {
1653 # Install the reg names
1656 update_registers all
1659 # Convert regena into a list of the enabled $regnums
1661 proc recompute_reg_display_list
{num_regs
} {
1662 global reg_display_list
1666 catch {unset reg_display_list
}
1669 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1671 if {[set regena
($regnum)] != 0} {
1672 lappend reg_display_list
$regnum
1673 set regmap
($regnum) $line
1679 # Fill out the register window with the names of the regs specified in
1682 proc populate_reg_window
{} {
1683 global max_regname_width
1684 global reg_display_list
1686 .reg.
text configure
-state normal
1688 .reg.
text delete
0.0 end
1690 set regnames
[eval gdb_regnames
$reg_display_list]
1692 # Figure out the longest register name
1694 set max_regname_width
0
1696 foreach reg
$regnames {
1697 set len
[string length
$reg]
1698 if {$len > $max_regname_width} {set max_regname_width
$len}
1701 set width
[expr $max_regname_width + 15]
1703 set height
[llength $regnames]
1705 if {$height > 60} {set height
60}
1707 .reg.
text configure
-height $height -width $width
1709 foreach reg
$regnames {
1710 .reg.
text insert end
[format "%-*s \n" $max_regname_width ${reg
}]
1714 .reg.
text configure
-state disabled
1720 # update_registers - Update the registers window.
1724 # This procedure updates the registers window.
1727 proc update_registers
{which
} {
1728 global max_regname_width
1730 global reg_display_list
1731 global changed_reg_list
1735 set margin
[expr $max_regname_width + 1]
1737 set winwidth
[lindex [$win configure
-width] 4]
1738 set valwidth
[expr $winwidth - $margin]
1740 $win configure
-state normal
1742 if {$which == "all"} {
1744 foreach regnum
$reg_display_list {
1745 set regval
[gdb_fetch_registers
$reg_format $regnum]
1746 set regval
[format "%-*s" $valwidth $regval]
1747 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
1748 $win insert
$lineindex.
$margin $regval
1751 $win configure
-state disabled
1755 # Unhighlight the old values
1757 foreach regnum
$changed_reg_list {
1758 $win tag delete
$win.
$regnum
1761 # Now, highlight the changed values of the interesting registers
1763 set changed_reg_list
[eval gdb_changed_register_list
$reg_display_list]
1766 foreach regnum
$changed_reg_list {
1767 set regval
[gdb_fetch_registers
$reg_format $regnum]
1768 set regval
[format "%-*s" $valwidth $regval]
1770 set lineindex
$regmap($regnum)
1771 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
1772 $win insert
$lineindex.
$margin $regval
1773 $win tag add
$win.
$regnum $lineindex.0 "$lineindex.0 lineend"
1774 eval $win tag configure
$win.
$regnum $highlight
1777 $win configure
-state disabled
1783 # update_assembly - Update the assembly window.
1787 # This procedure updates the assembly window.
1790 proc update_assembly
{linespec
} {
1792 global screen_height
1796 global current_label
1798 global file_to_debug_file
1799 global current_asm_label
1801 global asm_screen_height asm_screen_top asm_screen_bot
1804 # Rip the linespec apart
1806 set pc
[lindex $linespec 4]
1807 set line
[lindex $linespec 3]
1808 set filename [lindex $linespec 2]
1809 set funcname
[lindex $linespec 1]
1810 set debug_file
[lindex $linespec 0]
1812 set win
[asm_win_name
$cfunc]
1814 # Sometimes there's no source file for this location
1816 if {$filename == ""} {set filename Blank
}
1818 # If we want to switch funcs, we need to unpack the current text widget, and
1819 # stick in the new one.
1821 if {$funcname != $cfunc } {
1825 set win
[asm_win_name
$cfunc]
1827 # Create a text widget for this func if necessary
1829 if {![winfo exists
$win]} {
1830 create_asm_win
$cfunc $pc
1831 set asm_pointers
($cfunc) 1.1
1832 set current_asm_label NIL
1835 # Pack the text widget, and scroll to the right place
1838 pack $win -side left
-expand yes
-fill both
\
1840 .asm.scroll configure
-command "$win yview"
1841 set line
[pc_to_line
$pclist($cfunc) $pc]
1843 $win yview
[expr $line - $asm_screen_height / 2]
1846 # Update the label widget in case the filename or function name has changed
1848 if {$current_asm_label != "$pc $funcname"} then
{
1849 set .asm.
label "$pc $funcname"
1850 set current_asm_label
"$pc $funcname"
1853 # Update the pointer, scrolling the text widget if necessary to keep the
1854 # pointer in an acceptable part of the screen.
1856 if [info exists asm_pointers
($cfunc)] then
{
1857 $win configure
-state normal
1858 set pointer_pos
$asm_pointers($cfunc)
1859 $win configure
-state normal
1860 $win delete
$pointer_pos "$pointer_pos + 2 char"
1861 $win insert
$pointer_pos " "
1863 # Map the PC back to a line in the window
1865 set line
[pc_to_line
$pclist($cfunc) $pc]
1868 echo
"Can't find PC $pc"
1872 set pointer_pos
[$win index
$line.1]
1873 set asm_pointers
($cfunc) $pointer_pos
1875 $win delete
$pointer_pos "$pointer_pos + 2 char"
1876 $win insert
$pointer_pos "->"
1878 if {$line < $asm_screen_top + 1
1879 ||
$line > $asm_screen_bot} then
{
1880 $win yview
[expr $line - $asm_screen_height / 2]
1883 $win configure
-state disabled
1890 # update_ptr - Update the listing window.
1894 # This routine will update the listing window using the result of
1898 proc update_ptr
{} {
1899 update_listing
[gdb_loc
]
1900 if [winfo exists .asm
] {
1901 update_assembly
[gdb_loc
]
1903 if [winfo exists .reg
] {
1904 update_registers changed
1906 if [winfo exists .
expr] {
1909 if [winfo exists .autocmd
] {
1914 # Make toplevel window disappear
1918 proc files_command
{} {
1919 toplevel .files_window
1921 wm minsize .files_window
1 1
1922 # wm overrideredirect .files_window true
1923 listbox .files_window.
list -geometry 30x20
-setgrid true
\
1924 -yscrollcommand {.files_window.scroll
set} -relief sunken
\
1926 scrollbar .files_window.scroll
-orient vertical
\
1927 -command {.files_window.
list yview
} -relief sunken
1928 button .files_window.
close -text Close
-command {destroy .files_window
}
1929 tk_listboxSingleSelect .files_window.
list
1931 # Get the file list from GDB, sort it, and format it as one entry per line.
1933 set filelist
[join [lsort [gdb_listfiles
]] "\n"]
1935 # Now, remove duplicates (by using uniq)
1937 set fh
[open "| uniq > /tmp/gdbtk.[pid]" w
]
1940 set fh
[open /tmp
/gdbtk.
[pid]]
1941 set filelist
[split [read $fh] "\n"]
1942 set filelist
[lrange $filelist 0 [expr [llength $filelist] - 2]]
1944 exec rm
/tmp
/gdbtk.
[pid]
1946 # Insert the file list into the widget
1948 eval .files_window.
list insert
0 $filelist
1950 pack .files_window.
close -side bottom
-fill x
-expand no
-anchor s
1951 pack .files_window.scroll
-side right
-fill both
1952 pack .files_window.
list -side left
-fill both
-expand yes
1953 bind .files_window.
list <Any-ButtonRelease-1
> {
1954 set file [%W get
[%W curselection
]]
1955 gdb_cmd
"list $file:1,0"
1956 update_listing
[gdb_loc
$file:1]
1957 destroy .files_window
}
1960 button .files
-text Files
-command files_command
1962 proc apply_filespec
{label default command
} {
1963 set filename [FSBox
$label $default]
1964 if {$filename != ""} {
1965 if [catch {gdb_cmd
"$command $filename"} retval
] {
1966 tk_dialog .filespec_error
"gdb : $label error" \
1967 "Error in command \"$command $filename\"" {} 0 Dismiss
1974 # Setup command window
1976 proc build_framework
{win
{title GDBtk
} {label {}}} {
1980 wm title
${win
} $title
1981 wm minsize
${win
} 1 1
1983 frame ${win
}.menubar
1985 menubutton ${win
}.menubar.
file -padx 12 -text File
\
1986 -menu ${win
}.menubar.
file.
menu -underline 0
1988 menu ${win
}.menubar.
file.
menu
1989 ${win
}.menubar.
file.
menu add command
-label File...
\
1990 -command {apply_filespec File a.out
file}
1991 ${win
}.menubar.
file.
menu add command
-label Target...
\
1992 -command { not_implemented_yet
"target" }
1993 ${win
}.menubar.
file.
menu add command
-label Edit
\
1994 -command {exec $editor +[expr ($screen_top + $screen_bot)/2] $cfile &}
1995 ${win
}.menubar.
file.
menu add separator
1996 ${win
}.menubar.
file.
menu add command
-label "Exec File..." \
1997 -command {apply_filespec
{Exec File
} a.out exec-file
}
1998 ${win
}.menubar.
file.
menu add command
-label "Symbol File..." \
1999 -command {apply_filespec
{Symbol File
} a.out symbol-file
}
2000 ${win
}.menubar.
file.
menu add command
-label "Add Symbol File..." \
2001 -command { not_implemented_yet
"menu item, add symbol file" }
2002 ${win
}.menubar.
file.
menu add command
-label "Core File..." \
2003 -command {apply_filespec
{Core File
} core core-file
}
2005 ${win
}.menubar.
file.
menu add separator
2006 ${win
}.menubar.
file.
menu add command
-label Close
\
2007 -command "destroy ${win}"
2008 ${win
}.menubar.
file.
menu add separator
2009 ${win
}.menubar.
file.
menu add command
-label Quit
\
2010 -command {interactive_cmd quit
}
2012 menubutton ${win
}.menubar.commands
-padx 12 -text Commands
\
2013 -menu ${win
}.menubar.commands.
menu -underline 0
2015 menu ${win
}.menubar.commands.
menu
2016 ${win
}.menubar.commands.
menu add command
-label Run
\
2017 -command {interactive_cmd run
}
2018 ${win
}.menubar.commands.
menu add command
-label Step
\
2019 -command {interactive_cmd step
}
2020 ${win
}.menubar.commands.
menu add command
-label Next
\
2021 -command {interactive_cmd next
}
2022 ${win
}.menubar.commands.
menu add command
-label Continue
\
2023 -command {interactive_cmd
continue}
2024 ${win
}.menubar.commands.
menu add separator
2025 ${win
}.menubar.commands.
menu add command
-label Stepi
\
2026 -command {interactive_cmd stepi
}
2027 ${win
}.menubar.commands.
menu add command
-label Nexti
\
2028 -command {interactive_cmd nexti
}
2030 menubutton ${win
}.menubar.view
-padx 12 -text Options
\
2031 -menu ${win
}.menubar.view.
menu -underline 0
2033 menu ${win
}.menubar.view.
menu
2034 ${win
}.menubar.view.
menu add command
-label Hex
\
2036 ${win
}.menubar.view.
menu add command
-label Decimal
\
2037 -command {echo Decimal
}
2038 ${win
}.menubar.view.
menu add command
-label Octal
\
2039 -command {echo Octal
}
2041 menubutton ${win
}.menubar.window
-padx 12 -text Window
\
2042 -menu ${win
}.menubar.window.
menu -underline 0
2044 menu ${win
}.menubar.window.
menu
2045 ${win
}.menubar.window.
menu add command
-label Command
\
2046 -command create_command_window
2047 ${win
}.menubar.window.
menu add separator
2048 ${win
}.menubar.window.
menu add command
-label Source
\
2049 -command create_source_window
2050 ${win
}.menubar.window.
menu add command
-label Assembly
\
2051 -command create_asm_window
2052 ${win
}.menubar.window.
menu add separator
2053 ${win
}.menubar.window.
menu add command
-label Registers
\
2054 -command create_registers_window
2055 ${win
}.menubar.window.
menu add command
-label Expressions
\
2056 -command create_expr_window
2057 ${win
}.menubar.window.
menu add command
-label "Auto Command" \
2058 -command create_autocmd_window
2059 ${win
}.menubar.window.
menu add command
-label Breakpoints
\
2060 -command create_breakpoints_window
2062 # ${win}.menubar.window.menu add separator
2063 # ${win}.menubar.window.menu add command -label Files \
2064 # -command { not_implemented_yet "files window" }
2066 menubutton ${win
}.menubar.help
-padx 12 -text Help
\
2067 -menu ${win
}.menubar.help.
menu -underline 0
2069 menu ${win
}.menubar.help.
menu
2070 ${win
}.menubar.help.
menu add command
-label "with GDBtk" \
2071 -command {echo
"with GDBtk"}
2072 ${win
}.menubar.help.
menu add command
-label "with this window" \
2073 -command {echo
"with this window"}
2074 ${win
}.menubar.help.
menu add command
-label "Report bug" \
2075 -command {exec send-pr
}
2077 tk_menuBar
${win
}.menubar
\
2078 ${win
}.menubar.
file \
2079 ${win
}.menubar.view
\
2080 ${win
}.menubar.window
\
2082 pack ${win
}.menubar.
file \
2083 ${win
}.menubar.view
\
2084 ${win
}.menubar.window
-side left
2085 pack ${win
}.menubar.help
-side right
2088 text ${win
}.
text -height 25 -width 80 -relief sunken
-borderwidth 2 \
2089 -setgrid true
-cursor hand2
-yscrollcommand "${win}.scroll set"
2091 set ${win
}.
label $label
2092 label ${win
}.
label -textvariable ${win
}.
label -borderwidth 2 -relief sunken
2094 scrollbar ${win
}.scroll
-orient vertical
-command "${win}.text yview" \
2097 bind $win <Key-Alt_R
> do_nothing
2098 bind $win <Key-Alt_L
> do_nothing
2099 bind $win <Key-Prior
> "$win yview {@0,0 - 10 lines}"
2100 bind $win <Key-Next
> "$win yview {@0,0 + 10 lines}"
2101 bind $win <Key-Up
> "$win yview {@0,0 - 1 lines}"
2102 bind $win <Key-Down
> "$win yview {@0,0 + 1 lines}"
2103 bind $win <Key-Home
> "$win yview -pickplace end"
2104 bind $win <Key-End
> "$win yview -pickplace end"
2106 pack ${win
}.
label -side bottom
-fill x
-in ${win
}.
info
2107 pack ${win
}.scroll
-side right
-fill y
-in ${win
}.
info
2108 pack ${win
}.
text -side left
-expand yes
-fill both
-in ${win
}.
info
2110 pack ${win
}.menubar
-side top
-fill x
2111 pack ${win
}.
info -side top
-fill both
-expand yes
2114 proc create_source_window
{} {
2118 if [winfo exists .src
] {raise .src
; return}
2120 build_framework .src Source
"*No file*"
2122 # First, delete all the old view menu entries
2124 .src.menubar.view.
menu delete
0 last
2126 # Source file selection
2127 .src.menubar.view.
menu add command
-label "Select source file" \
2128 -command files_command
2130 # Line numbers enable/disable menu item
2131 .src.menubar.view.
menu add
checkbutton -variable line_numbers
\
2132 -label "Line numbers" -onvalue 1 -offvalue 0 -command {
2133 foreach source [array names wins
] {
2134 if {$source == "Blank"} continue
2135 destroy $wins($source)
2139 update_listing
[gdb_loc
]
2145 button .src.start
-width 6 -text Start
-command \
2146 {interactive_cmd
{break main
}
2147 interactive_cmd
{enable delete
$bpnum}
2148 interactive_cmd run
}
2149 button .src.stop
-width 6 -text Stop
-fg red
-activeforeground red
\
2150 -state disabled
-command gdb_stop
2151 button .src.step
-width 6 -text Step
\
2152 -command {interactive_cmd step
}
2153 button .src.next
-width 6 -text Next
\
2154 -command {interactive_cmd next
}
2155 button .src.
continue -width 6 -text Cont
\
2156 -command {interactive_cmd
continue}
2157 button .src.finish
-width 6 -text Finish
\
2158 -command {interactive_cmd finish
}
2159 button .src.up
-width 6 -text Up
\
2160 -command {interactive_cmd up
}
2161 button .src.down
-width 6 -text Down
\
2162 -command {interactive_cmd down
}
2163 button .src.bottom
-width 6 -text Bottom
\
2164 -command {interactive_cmd
{frame 0}}
2166 pack .src.start .src.step .src.
continue .src.up .src.bottom
\
2167 -side left
-padx 3 -pady 5 -in .src.row1
2168 pack .src.stop .src.next .src.finish .src.down
-side left
-padx 3 \
2169 -pady 5 -in .src.row2
2171 pack .src.row2 .src.row1
-side bottom
-anchor w
-before .src.
info
2173 $wins($cfile) insert
0.0 " This page intentionally left blank."
2174 $wins($cfile) configure
-width 88 -state disabled
\
2175 -yscrollcommand textscrollproc
2177 proc textscrollproc
{args
} {global screen_height screen_top screen_bot
2178 eval ".src.scroll set $args"
2179 set screen_height
[lindex $args 1]
2180 set screen_top
[lindex $args 2]
2181 set screen_bot
[lindex $args 3]}
2184 proc update_autocmd
{} {
2185 global .autocmd.
label
2186 global accumulate_output
2188 catch {gdb_cmd
"${.autocmd.label}"} result
2189 if !$accumulate_output { .autocmd.
text delete
0.0 end
}
2190 .autocmd.
text insert end
$result
2191 .autocmd.
text yview
-pickplace end
2194 proc create_autocmd_window
{} {
2195 global .autocmd.
label
2197 if [winfo exists .autocmd
] {raise .autocmd
; return}
2199 build_framework .autocmd
"Auto Command" ""
2201 # First, delete all the old view menu entries
2203 .autocmd.menubar.view.
menu delete
0 last
2205 # Accumulate output option
2207 .autocmd.menubar.view.
menu add
checkbutton \
2208 -variable accumulate_output
\
2209 -label "Accumulate output" -onvalue 1 -offvalue 0
2211 # Now, create entry widget with label
2213 frame .autocmd.entryframe
2215 entry .autocmd.
entry -borderwidth 2 -relief sunken
2216 bind .autocmd
<Enter
> {focus .autocmd.
entry}
2217 bind .autocmd.
entry <Key-Return
> {set .autocmd.
label [.autocmd.
entry get
]
2218 .autocmd.
entry delete
0 end
}
2220 label .autocmd.entrylab
-text "Command: "
2222 pack .autocmd.entrylab
-in .autocmd.entryframe
-side left
2223 pack .autocmd.
entry -in .autocmd.entryframe
-side left
-fill x
-expand yes
2225 pack .autocmd.entryframe
-side bottom
-fill x
-before .autocmd.
info
2228 # Return the longest common prefix in SLIST. Can be empty string.
2230 proc find_lcp slist
{
2231 # Handle trivial cases where list is empty or length 1
2232 if {[llength $slist] <= 1} {return [lindex $slist 0]}
2234 set prefix
[lindex $slist 0]
2235 set prefixlast
[expr [string length
$prefix] - 1]
2237 foreach str
[lrange $slist 1 end
] {
2238 set test_str
[string range
$str 0 $prefixlast]
2239 while {[string compare
$test_str $prefix] != 0} {
2241 set prefix
[string range
$prefix 0 $prefixlast]
2242 set test_str
[string range
$str 0 $prefixlast]
2244 if {$prefixlast < 0} break
2249 # Look through COMPLETIONS to generate the suffix needed to do command
2250 # completion on CMD.
2252 proc find_completion
{cmd completions
} {
2253 # Get longest common prefix
2254 set lcp
[find_lcp
$completions]
2255 set cmd_len
[string length
$cmd]
2256 # Return suffix beyond end of cmd
2257 return [string range
$lcp $cmd_len end
]
2260 proc create_command_window
{} {
2265 if [winfo exists .cmd
] {raise .cmd
; return}
2267 build_framework .cmd Command
"* Command Buffer *"
2271 gdb_cmd
{set language c
}
2272 gdb_cmd
{set height
0}
2273 gdb_cmd
{set width
0}
2275 bind .cmd.
text <Enter
> {focus %W
}
2276 bind .cmd.
text <Delete
> {delete_char
%W
}
2277 bind .cmd.
text <BackSpace
> {delete_char
%W
}
2278 bind .cmd.
text <Control-c
> gdb_stop
2279 bind .cmd.
text <Control-u
> {delete_line
%W
}
2280 bind .cmd.
text <Any-Key
> {
2286 %W yview
-pickplace end
2287 append command_line
%A
2289 bind .cmd.
text <Key-Return
> {
2295 interactive_cmd
$command_line
2297 # %W yview -pickplace end
2298 # catch "gdb_cmd [list $command_line]" result
2299 # %W insert end $result
2302 %W insert end
"(gdb) "
2303 %W yview
-pickplace end
2305 bind .cmd.
text <Button-2
> {
2308 %W insert end
[selection get
]
2309 %W yview
-pickplace end
2310 append command_line
[selection get
]
2312 bind .cmd.
text <Key-Tab
> {
2317 set choices
[gdb_cmd
"complete $command_line"]
2318 set choices
[string trimright
$choices \n]
2319 set choices
[split $choices \n]
2321 # Just do completion if this is the first tab
2324 set completion
[find_completion
$command_line $choices]
2325 append command_line
$completion
2326 # Here is where the completion is actually done. If there is one match,
2327 # complete the command and print a space. If two or more matches, complete the
2328 # command and beep. If no match, just beep.
2329 switch -exact [llength $choices] {
2331 1 {%W insert end
"$completion "
2332 append command_line
" "
2334 default {%W insert end
"$completion"}
2336 puts -nonewline stdout
\007
2338 %W yview
-pickplace end
2340 # User hit another consecutive tab. List the choices. Note that at this
2341 # point, choices may contain commands with spaces. We have to lop off
2342 # everything before (and including) the last space so that the completion
2343 # list only shows the possibilities for the last token.
2345 set choices
[lsort $choices]
2346 if [regexp ".* " $command_line prefix
] {
2347 regsub -all $prefix $choices {} choices
2349 %W insert end
"\n[join $choices { }]\n(gdb) $command_line"
2350 %W yview
-pickplace end
2353 proc delete_char
{win
} {
2356 tk_textBackspace
$win
2357 $win yview
-pickplace insert
2358 set tmp
[expr [string length
$command_line] - 2]
2359 set command_line
[string range
$command_line 0 $tmp]
2361 proc delete_line
{win
} {
2364 $win delete
{end linestart
+ 6 chars
} end
2365 $win yview
-pickplace insert
2372 # simple file selector.
2374 # Mario Jorge Silva msilva@cs.Berkeley.EDU
2375 # University of California Berkeley Ph: +1(510)642-8248
2376 # Computer Science Division, 571 Evans Hall Fax: +1(510)642-5775
2380 # Copyright 1993 Regents of the University of California
2381 # Permission to use, copy, modify, and distribute this
2382 # software and its documentation for any purpose and without
2383 # fee is hereby granted, provided that this copyright
2384 # notice appears in all copies. The University of California
2385 # makes no representations about the suitability of this
2386 # software for any purpose. It is provided "as is" without
2387 # express or implied warranty.
2391 # names starting with "fileselect" are reserved by this module
2392 # no other names used.
2393 # Hack - FSBox is defined instead of fileselect for backwards compatibility
2396 # this is the proc that creates the file selector box
2397 # purpose - comment string
2398 # defaultName - initial value for name
2399 # cmd - command to eval upon OK
2400 # errorHandler - command to eval upon Cancel
2401 # If neither cmd or errorHandler are specified, the return value
2402 # of the FSBox procedure is the selected file name.
2404 proc FSBox
{{purpose
"Select file:"} {defaultName
""} {cmd
""} {errorHandler
2408 if [Exwin_Toplevel
$w "Select File" FileSelect
] {
2409 # path independent names for the widgets
2411 set fileselect
(list) $w.
file.sframe.
list
2412 set fileselect
(scroll
) $w.
file.sframe.scroll
2413 set fileselect
(direntry
) $w.
file.f1.direntry
2414 set fileselect
(entry) $w.
file.f2.
entry
2415 set fileselect
(ok
) $w.but.ok
2416 set fileselect
(cancel
) $w.but.cancel
2417 set fileselect
(msg
) $w.
label
2419 set fileselect
(result
) "" ;# value to return if no callback procedures
2422 Widget_Label
$w label {top fillx pady
10 padx
20} -anchor w
-width 24
2423 Widget_Frame
$w file Dialog
{left expand fill
} -bd 10
2425 Widget_Frame
$w.
file f1 Exmh
{top fillx
}
2426 Widget_Label
$w.
file.f1
label {left
} -text "Dir"
2427 Widget_Entry
$w.
file.f1 direntry
{right fillx expand
} -width 30
2429 Widget_Frame
$w.
file sframe
2431 scrollbar $w.
file.sframe.yscroll
-relief sunken
\
2432 -command [list $w.
file.sframe.
list yview
]
2433 listbox $w.
file.sframe.
list -relief sunken
\
2434 -yscroll [list $w.
file.sframe.yscroll
set] -setgrid 1
2435 pack append $w.
file.sframe
\
2436 $w.
file.sframe.yscroll
{right filly
} \
2437 $w.
file.sframe.
list {left expand fill
}
2439 Widget_Frame
$w.
file f2 Exmh
{top fillx
}
2440 Widget_Label
$w.
file.f2
label {left
} -text Name
2441 Widget_Entry
$w.
file.f2
entry {right fillx expand
}
2444 $w.but.quit configure
-text Cancel
\
2445 -command [list fileselect.cancel.cmd
$w]
2447 Widget_AddBut
$w.but ok OK
\
2448 [list fileselect.ok.cmd
$w $cmd $errorHandler] {left padx
1}
2450 Widget_AddBut
$w.but
list List
\
2451 [list fileselect.
list.cmd
$w] {left padx
1}
2452 Widget_CheckBut
$w.but listall
"List all" fileselect
(pattern
)
2453 $w.but.listall configure
-onvalue "{*,.*}" -offvalue "*" \
2454 -command {fileselect.
list.cmd
$fileselect(direntry
)}
2455 $w.but.listall deselect
2457 # Set up bindings for the browser.
2458 foreach ww
[list $w $fileselect(entry)] {
2459 bind $ww <Return
> [list $fileselect(ok
) invoke
]
2460 bind $ww <Control-c
> [list $fileselect(cancel
) invoke
]
2462 bind $fileselect(direntry
) <Return
> [list fileselect.
list.cmd
%W
]
2463 bind $fileselect(direntry
) <Tab
> [list fileselect.tab.dircmd
]
2464 bind $fileselect(entry) <Tab
> [list fileselect.tab.filecmd
]
2466 tk_listboxSingleSelect
$fileselect(list)
2469 bind $fileselect(list) <Button-1
> {
2470 # puts stderr "button 1 release"
2471 %W select from
[%W nearest
%y
]
2472 $fileselect(entry) delete
0 end
2473 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2476 bind $fileselect(list) <Key
> {
2477 %W select from
[%W nearest
%y
]
2478 $fileselect(entry) delete
0 end
2479 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2482 bind $fileselect(list) <Double-ButtonPress-1
> {
2483 # puts stderr "double button 1"
2484 %W select from
[%W nearest
%y
]
2485 $fileselect(entry) delete
0 end
2486 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2487 $fileselect(ok
) invoke
2490 bind $fileselect(list) <Return
> {
2491 %W select from
[%W nearest
%y
]
2492 $fileselect(entry) delete
0 end
2493 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2494 $fileselect(ok
) invoke
2497 set fileselect
(text) $purpose
2498 $fileselect(msg
) configure
-text $purpose
2499 $fileselect(entry) delete
0 end
2500 $fileselect(entry) insert
0 [file tail
$defaultName]
2502 if {[info exists fileselect
(lastDir
)] && ![string length
$defaultName]} {
2503 set dir
$fileselect(lastDir
)
2505 set dir
[file dirname
$defaultName]
2507 set fileselect
(pwd) [pwd]
2509 $fileselect(direntry
) delete
0 end
2510 $fileselect(direntry
) insert
0 [pwd]/
2512 $fileselect(list) delete
0 end
2513 $fileselect(list) insert
0 "Big directory:"
2514 $fileselect(list) insert
1 $dir
2515 $fileselect(list) insert
2 "Press Return for Listing"
2517 fileselect.
list.cmd
$fileselect(direntry
) startup
2519 # set kbd focus to entry widget
2521 # Exwin_ToplevelFocus $w $fileselect(entry)
2523 # Wait for button hits if no callbacks are defined
2525 if {"$cmd" == "" && "$errorHandler" == ""} {
2526 # wait for the box to be destroyed
2529 tkwait variable fileselect
(result
)
2532 set path
$fileselect(result
)
2533 set fileselect
(lastDir
) [pwd]
2534 fileselect.
cd $fileselect(pwd)
2535 return [string trimright
[string trim
$path] /]
2537 fileselect.
cd $fileselect(pwd)
2541 proc fileselect.
cd { dir
} {
2543 if [catch {cd $dir} err
] {
2548 # auxiliary button procedures
2550 proc fileselect.yck
{ {tag
{}} } {
2552 $fileselect(msg
) configure
-text "Yck! $tag"
2554 proc fileselect.ok
{} {
2556 $fileselect(msg
) configure
-text $fileselect(text)
2559 proc fileselect.cancel.cmd
{w
} {
2561 set fileselect
(result
) {}
2565 proc fileselect.
list.cmd
{w
{state normal
}} {
2567 set seldir
[$fileselect(direntry
) get
]
2568 if {[catch {glob $seldir} dir
]} {
2569 fileselect.yck
"glob failed"
2572 if {[llength $dir] > 1} {
2573 set dir
[file dirname
$seldir]
2574 set pat
[file tail
$seldir]
2576 set pat
$fileselect(pattern
)
2580 if [file isdirectory
$dir] {
2581 fileselect.getfiles
$dir $pat $state
2582 focus $fileselect(entry)
2584 fileselect.yck
"not a dir"
2588 proc fileselect.ok.cmd
{w cmd errorHandler
} {
2590 set selname
[$fileselect(entry) get
]
2591 set seldir
[$fileselect(direntry
) get
]
2593 if [string match
/* $selname] {
2594 set selected
$selname
2596 if [string match ~
* $selname] {
2597 set selected
$selname
2599 set selected
$seldir/$selname
2603 # some nasty file names may cause "file isdirectory" to return an error
2604 if [catch {file isdirectory
$selected} isdir
] {
2605 fileselect.yck
"isdirectory failed"
2608 if [catch {glob $selected} globlist
] {
2609 if ![file isdirectory
[file dirname
$selected]] {
2610 fileselect.yck
"bad pathname"
2613 set globlist
$selected
2618 if {[llength $globlist] > 1} {
2619 set dir
[file dirname
$selected]
2620 set pat
[file tail
$selected]
2621 fileselect.getfiles
$dir $pat
2624 set selected
$globlist
2626 if [file isdirectory
$selected] {
2627 fileselect.getfiles
$selected $fileselect(pattern
)
2628 $fileselect(entry) delete
0 end
2635 set fileselect
(result
) $selected
2640 proc fileselect.getfiles
{ dir
{pat
*} {state normal
} } {
2642 $fileselect(msg
) configure
-text Listing...
2645 set currentDir
[pwd]
2647 if [catch {set files
[lsort [glob -nocomplain $pat]]} err
] {
2648 $fileselect(msg
) configure
-text $err
2649 $fileselect(list) delete
0 end
2655 # Normal case - show current directory
2656 $fileselect(direntry
) delete
0 end
2657 $fileselect(direntry
) insert
0 [pwd]/
2660 # Directory already OK (tab related)
2663 # Changing directory (tab related)
2664 fileselect.
cd $currentDir
2667 # Avoid listing huge directories upon startup.
2668 $fileselect(direntry
) delete
0 end
2669 $fileselect(direntry
) insert
0 [pwd]/
2670 if {[llength $files] > 32} {
2677 # build a reordered list of the files: directories are displayed first
2678 # and marked with a trailing "/"
2679 if [string compare
$dir /] {
2680 fileselect.putfiles
$files [expr {($pat == "*") ?
1 : 0}]
2682 fileselect.putfiles
$files
2687 proc fileselect.putfiles
{files
{dotdot
0} } {
2690 $fileselect(list) delete
0 end
2692 $fileselect(list) insert end
"../"
2695 if {[file isdirectory
$i]} {
2696 $fileselect(list) insert end
$i/
2698 $fileselect(list) insert end
$i
2703 proc FileExistsDialog
{ name
} {
2706 set fileExists
(ok
) 0
2708 message $w.msg
-aspect 1000
2709 pack $w.msg
-side top
-fill both
-padx 20 -pady 20
2710 $w.but.quit config
-text Cancel
-command {FileExistsCancel
}
2711 button $w.but.ok
-text OK
-command {FileExistsOK
}
2712 pack $w.but.ok
-side left
2713 bind $w.msg
<Return
> {FileExistsOK
}
2715 $w.msg config
-text "Warning: file exists
2717 OK to overwrite it?"
2719 set fileExists
(focus) [focus]
2722 tkwait variable fileExists
(ok
)
2725 return $fileExists(ok
)
2727 proc FileExistsCancel
{} {
2729 set fileExists
(ok
) 0
2731 proc FileExistsOK
{} {
2733 set fileExists
(ok
) 1
2736 proc fileselect.getfiledir
{ dir
{basedir
[pwd]} } {
2739 set path
[$fileselect(direntry
) get
]
2743 if {[string index
$path 0] == "~"} {
2747 set path
[$fileselect(entry) get
]
2749 if [catch {set listFile
[glob -nocomplain $path*]}] {
2752 foreach el
$listFile {
2754 if [file isdirectory
$el] {
2755 lappend returnList
[file tail
$el]
2757 } elseif
![file isdirectory
$el] {
2758 lappend returnList
[file tail
$el]
2765 proc fileselect.gethead
{ list } {
2768 for {set i
0} {[string length
[lindex $list 0]] > $i}\
2769 {incr i
; set returnHead
$returnHead$thisChar} {
2770 set thisChar
[string index
[lindex $list 0] $i]
2772 if {[string length
$el] < $i} {
2775 if {$thisChar != [string index
$el $i]} {
2783 proc fileselect.expand.tilde
{ } {
2786 set entry [$fileselect(direntry
) get
]
2787 set dir
[string range
$entry 1 [string length
$entry]]
2795 ## look in /etc/passwd
2796 if [file exists
/etc
/passwd
] {
2797 if [catch {set users
[exec cat
/etc
/passwd | sed s
/:.
*//]} err
] {
2798 puts "Error\#1 $err"
2801 set list [split $users "\n"]
2803 if {[lsearch -exact $list "+"] != -1} {
2804 if [catch {set users
[exec ypcat passwd | sed s
/:.
*//]} err
] {
2805 puts "Error\#2 $err"
2808 set list [concat $list [split $users "\n"]]
2810 $fileselect(list) delete
0 end
2812 if [string match
$dir* $el] {
2813 lappend listmatch
$el
2814 $fileselect(list) insert end
$el
2817 set addings
[fileselect.gethead
$listmatch]
2818 if {$addings == ""} {
2821 $fileselect(direntry
) delete
0 end
2822 if {[llength $listmatch] == 1} {
2823 $fileselect(direntry
) insert
0 [file dirname ~
$addings/]
2824 fileselect.getfiles
[$fileselect(direntry
) get
]
2826 $fileselect(direntry
) insert
0 ~
$addings
2830 proc fileselect.tab.dircmd
{ } {
2833 set dir
[$fileselect(direntry
) get
]
2835 $fileselect(direntry
) delete
0 end
2836 $fileselect(direntry
) insert
0 [pwd]
2837 if [string compare
[pwd] "/"] {
2838 $fileselect(direntry
) insert end
/
2842 if [catch {set tmp
[file isdirectory
[file dirname
$dir]]}] {
2843 if {[string index
$dir 0] == "~"} {
2844 fileselect.expand.tilde
2851 set dirFile
[fileselect.getfiledir
1 $dir]
2852 if ![llength $dirFile] {
2855 if {[llength $dirFile] == 1} {
2856 $fileselect(direntry
) delete
0 end
2857 $fileselect(direntry
) insert
0 [file dirname
$dir]
2858 if [string compare
[file dirname
$dir] /] {
2859 $fileselect(direntry
) insert end
/[lindex $dirFile 0]/
2861 $fileselect(direntry
) insert end
[lindex $dirFile 0]/
2863 fileselect.getfiles
[$fileselect(direntry
) get
] \
2864 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2867 set headFile
[fileselect.gethead
$dirFile]
2868 $fileselect(direntry
) delete
0 end
2869 $fileselect(direntry
) insert
0 [file dirname
$dir]
2870 if [string compare
[file dirname
$dir] /] {
2871 $fileselect(direntry
) insert end
/$headFile
2873 $fileselect(direntry
) insert end
$headFile
2875 if {$headFile == "" && [file isdirectory
$dir]} {
2876 fileselect.getfiles
$dir\
2877 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2879 fileselect.getfiles
[file dirname
$dir]\
2880 "[file tail [$fileselect(direntry) get]]*" newdir
2884 proc fileselect.tab.filecmd
{ } {
2887 set dir
[$fileselect(direntry
) get
]
2891 if {![file isdirectory
$dir]} {
2892 error "dir $dir doesn't exist"
2894 set listFile
[fileselect.getfiledir
0 $dir]
2896 if ![llength $listFile] {
2899 if {[llength $listFile] == 1} {
2900 $fileselect(entry) delete
0 end
2901 $fileselect(entry) insert
0 [lindex $listFile 0]
2904 set headFile
[fileselect.gethead
$listFile]
2905 $fileselect(entry) delete
0 end
2906 $fileselect(entry) insert
0 $headFile
2907 fileselect.getfiles
$dir "[$fileselect(entry) get]$fileselect(pattern)" opt
2910 proc Exwin_Toplevel
{ path name
{class Dialog
} {dismiss yes
}} {
2912 if [catch {wm state
$path} state
] {
2913 set t
[Widget_Toplevel
$path $name $class]
2914 if ![info exists exwin
(toplevels
)] {
2915 set exwin
(toplevels
) [option get . exwinPaths
{}]
2917 set ix
[lsearch $exwin(toplevels
) $t]
2919 lappend exwin
(toplevels
) $t
2921 if {$dismiss == "yes"} {
2922 set f
[Widget_Frame
$t but Menubar
{top fill
}]
2923 Widget_AddBut
$f quit
"Dismiss" [list Exwin_Dismiss
$path]
2927 if {$state != "normal"} {
2929 wm geometry
$path $exwin(geometry
,$path)
2930 # Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
2940 proc Exwin_Dismiss
{ path
{geo ok
} } {
2944 set exwin
(geometry
,$path) [wm geometry
$path]
2947 set exwin
(geometry
,$path) [string trimleft
[wm geometry
$path] 0123456789x
]
2950 catch {unset exwin
(geometry
,$path)}
2956 proc Widget_Toplevel
{ path name
{class Dialog
} {x
{}} {y
{}} } {
2957 set self
[toplevel $path -class $class]
2958 set usergeo
[option get
$path position Position
]
2959 if {$usergeo != {}} {
2960 if [catch {wm geometry
$self $usergeo} err
] {
2961 # Exmh_Debug Widget_Toplevel $self $usergeo => $err
2964 if {($x != {}) && ($y != {})} {
2965 # Exmh_Debug Event position $self +$x+$y
2966 wm geometry
$self +$x+$y
2969 wm title
$self $name
2974 proc Widget_Frame
{par child
{class GDB
} {where
{top expand fill
}} args
} {
2978 set self
$par.
$child
2980 eval {frame $self -class $class} $args
2981 pack append $par $self $where
2985 proc Widget_AddBut
{par but txt cmd
{where
{right padx
1}} } {
2986 # Create a Packed button. Return the button pathname
2987 set cmd2
[list button $par.
$but -text $txt -command $cmd]
2988 if [catch $cmd2 t
] {
2989 puts stderr
"Widget_AddBut (warning) $t"
2990 eval $cmd2 {-font fixed
}
2992 pack append $par $par.
$but $where
2995 proc Widget_CheckBut
{par but txt var
{where
{right padx
1}} } {
2996 # Create a check button. Return the button pathname
2997 set cmd
[list checkbutton $par.
$but -text $txt -variable $var]
2999 puts stderr
"Widget_CheckBut (warning) $t"
3000 eval $cmd {-font fixed
}
3002 pack append $par $par.
$but $where
3006 proc Widget_Label
{ frame {name
label} {where
{left fill
}} args
} {
3007 set cmd
[list label $frame.
$name ]
3008 if [catch [concat $cmd $args] t
] {
3009 puts stderr
"Widget_Label (warning) $t"
3010 eval $cmd $args {-font fixed
}
3012 pack append $frame $frame.
$name $where
3015 proc Widget_Entry
{ frame {name
entry} {where
{left fill
}} args
} {
3016 set cmd
[list entry $frame.
$name ]
3017 if [catch [concat $cmd $args] t
] {
3018 puts stderr
"Widget_Entry (warning) $t"
3019 eval $cmd $args {-font fixed
}
3021 pack append $frame $frame.
$name $where
3025 # End of fileselect.tcl.
3027 # Setup the initial windows
3029 create_source_window
3031 if {[tk colormodel .src.
text] == "color"} {
3032 set highlight
"-background red2 -borderwidth 2 -relief sunk"
3034 set fg
[lindex [.src.
text config
-foreground] 4]
3035 set bg
[lindex [.src.
text config
-background] 4]
3036 set highlight
"-foreground $bg -background $fg -borderwidth 0"
3039 create_command_window
3041 # Create a copyright window
3045 wm geometry .c
+300+300
3046 wm overrideredirect .c true
3048 message .c.m
-text [gdb_cmd
"show version"] -aspect 500 -relief raised
3050 bind .c.m
<Leave
> {destroy .c
}
3053 if [file exists ~
/.gdbtkinit
] {