1 # GDB GUI setup for GDB, the GNU debugger.
2 # Copyright 1994, 1995, 1996
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
28 set breakpoint_file
(-1) {[garbage
]}
29 set disassemble_with_source nosource
30 set expr_update_list
(0) 0
32 #option add *Foreground Black
33 #option add *Background White
34 #option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1
36 proc echo
string {puts stdout
$string}
38 # Assign elements from LIST to variables named in ARGS. FIXME replace
39 # with TclX version someday.
40 proc lassign
{list args
} {
41 set len
[expr {[llength $args] - 1}]
43 upvar [lindex $args $len] local
44 set local
[lindex $list $len]
52 # decr (var val) - compliment to incr
57 proc decr
{var
{val
1}} {
59 set num
[expr {$num - $val}]
64 # Center a window on the screen.
66 proc center_window
toplevel {
67 # Withdraw and update, to ensure geometry computations are finished.
71 set x
[expr {[winfo screenwidth
$toplevel] / 2
72 - [winfo reqwidth
$toplevel] / 2
73 - [winfo vrootx
$toplevel]}]
74 set y
[expr {[winfo screenheight
$toplevel] / 2
75 - [winfo reqheight
$toplevel] / 2
76 - [winfo vrooty
$toplevel]}]
77 wm geometry
$toplevel +${x
}+${y
}
78 wm deiconify
$toplevel
82 # Rearrange the bindtags so the widget comes after the class. I was
83 # always for Ousterhout putting the class bindings first, but no...
85 proc bind_widget_after_class
{widget
} {
86 set class
[winfo class
$widget]
88 foreach tag
[bindtags $widget] {
89 if {$tag == $widget} {
94 lappend newList
$widget
98 bindtags $widget $newList
101 if {[info exists env
(EDITOR
)]} then
{
102 set editor
$env(EDITOR
)
109 # These functions are called by GDB (from C code) to do various things in
110 # TK-land. All start with the prefix `gdbtk_tcl_' to make them easy to find.
116 # gdbtk_tcl_fputs (text) - Output text to the command window
120 # GDB calls this to output TEXT to the GDB command window. The text is
121 # placed at the end of the text widget. Note that output may not occur,
122 # due to buffering. Use gdbtk_tcl_flush to cause an immediate update.
125 proc gdbtk_tcl_fputs
{arg
} {
126 .cmd.
text insert end
"$arg"
130 proc gdbtk_tcl_fputs_error
{arg
} {
131 .cmd.
text insert end
"$arg"
138 # gdbtk_tcl_flush () - Flush output to the command window
142 # GDB calls this to force all buffered text to the GDB command window.
145 proc gdbtk_tcl_flush
{} {
153 # gdbtk_tcl_query (message) - Create a yes/no query dialog box
157 # GDB calls this to create a yes/no dialog box containing MESSAGE. GDB
158 # is hung while the dialog box is active (ie: no commands will work),
159 # however windows can still be refreshed in case of damage or exposure.
162 proc gdbtk_tcl_query
{message} {
163 # FIXME We really want a Help button here. But Tk's brain-damaged
164 # modal dialogs won't really allow it. Should have async dialog
166 set result
[tk_dialog .query
"gdb : query" "$message" questhead
0 Yes No
]
167 return [expr {!$result}]
173 # gdbtk_start_variable_annotation (args ...) -
177 # Not yet implemented.
180 proc gdbtk_tcl_start_variable_annotation
{valaddr ref_type stor_cl
181 cum_expr field type_cast
} {
182 echo
"gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
188 # gdbtk_end_variable_annotation (args ...) -
192 # Not yet implemented.
195 proc gdbtk_tcl_end_variable_annotation
{} {
196 echo gdbtk_tcl_end_variable_annotation
202 # gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK
203 # interface of changes to breakpoints.
207 # GDB calls this to notify TK of changes to breakpoints. ACTION is one
209 # create - Notify of breakpoint creation
210 # delete - Notify of breakpoint deletion
211 # modify - Notify of breakpoint modification
214 # file line pc type enabled disposition silent ignore_count commands cond_string thread hit_count
216 proc gdbtk_tcl_breakpoint
{action bpnum
} {
217 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 enable
[lindex $bpinfo 4]
223 if {$action == "modify"} {
224 if {$enable == "1"} {
231 ${action
}_breakpoint
$bpnum $file $line $pc
234 proc create_breakpoints_window
{} {
237 if {[winfo exists .breakpoints
]} {raise .breakpoints
; return}
239 build_framework .breakpoints
"Breakpoints" ""
241 # First, delete all the old view menu entries
243 .breakpoints.menubar.view.
menu delete
0 last
247 destroy .breakpoints.
label
249 # Replace text with a canvas and fix the scrollbars
251 destroy .breakpoints.
text
252 scrollbar .breakpoints.scrollx
-orient horizontal
\
253 -command {.breakpoints.c xview
} -relief sunken
254 canvas .breakpoints.c
-relief sunken
-bd 2 \
256 -yscrollcommand {.breakpoints.scroll
set} \
257 -xscrollcommand {.breakpoints.scrollx
set}
258 .breakpoints.scroll configure
-command {.breakpoints.c yview
}
260 pack .breakpoints.scrollx
-side bottom
-fill x
-in .breakpoints.
info
261 pack .breakpoints.c
-side left
-expand yes
-fill both
\
262 -in .breakpoints.
info
266 # Create a frame for each breakpoint
268 foreach bpnum
[gdb_get_breakpoint_list
] {
269 add_breakpoint_frame
$bpnum
273 # Create a frame for bpnum in the .breakpoints canvas
275 proc add_breakpoint_frame bpnum
{
280 if {![winfo exists .breakpoints
]} return
282 set bpinfo
[gdb_get_breakpoint_info
$bpnum]
284 lassign
$bpinfo file line pc type enabled
($bpnum) disposition
($bpnum) \
285 silent ignore_count commands cond thread hit_count
287 set f .breakpoints.c.
$bpnum
289 if {![winfo exists
$f]} {
290 frame $f -relief sunken
-bd 2
292 label $f.id
-text "#$bpnum $file:$line ($pc)" \
293 -relief flat
-bd 2 -anchor w
295 label $f.hit_count.
label -text "Hit count:" -relief flat
\
296 -bd 2 -anchor w
-width 11
297 label $f.hit_count.val
-text $hit_count -relief flat
\
299 checkbutton $f.hit_count.enabled
-text Enabled
\
300 -variable enabled
($bpnum) -anchor w
-relief flat
302 pack $f.hit_count.
label $f.hit_count.val
-side left
303 pack $f.hit_count.enabled
-side right
306 label $f.thread.
label -text "Thread: " -relief flat
-bd 2 \
308 entry $f.thread.
entry -bd 2 -relief sunken
-width 10
309 $f.thread.
entry insert end
$thread
310 pack $f.thread.
label -side left
311 pack $f.thread.
entry -side left
-fill x
314 label $f.cond.
label -text "Condition: " -relief flat
-bd 2 \
316 entry $f.cond.
entry -bd 2 -relief sunken
317 $f.cond.
entry insert end
$cond
318 pack $f.cond.
label -side left
319 pack $f.cond.
entry -side left
-fill x
-expand yes
321 frame $f.ignore_count
322 label $f.ignore_count.
label -text "Ignore count: " \
323 -relief flat
-bd 2 -width 11 -anchor w
324 entry $f.ignore_count.
entry -bd 2 -relief sunken
-width 10
325 $f.ignore_count.
entry insert end
$ignore_count
326 pack $f.ignore_count.
label -side left
327 pack $f.ignore_count.
entry -side left
-fill x
331 label $f.disps.
label -text "Disposition: " -relief flat
-bd 2 \
334 radiobutton $f.disps.delete
-text Delete
\
335 -variable disposition
($bpnum) -anchor w
-relief flat
\
336 -command "gdb_cmd \"delete break $bpnum\"" \
339 radiobutton $f.disps.disable
-text Disable
\
340 -variable disposition
($bpnum) -anchor w
-relief flat
\
341 -command "gdb_cmd \"disable break $bpnum\"" \
344 radiobutton $f.disps.donttouch
-text "Leave alone" \
345 -variable disposition
($bpnum) -anchor w
-relief flat
\
346 -command "gdb_cmd \"enable break $bpnum\"" \
349 pack $f.disps.
label $f.disps.delete
$f.disps.disable
\
350 $f.disps.donttouch
-side left
-anchor w
351 text $f.commands
-relief sunken
-bd 2 -setgrid true
\
352 -cursor hand2
-height 3 -width 30
354 foreach line
$commands {
355 $f.commands insert end
"${line}\n"
358 pack $f.id
-side top
-anchor nw
-fill x
359 pack $f.hit_count
$f.cond
$f.thread
$f.ignore_count
$f.disps
\
360 $f.commands
-side top
-fill x
-anchor nw
363 set tag
[.breakpoints.c create window
0 $bpframe_lasty -window $f -anchor nw
]
365 set bbox
[.breakpoints.c bbox
$tag]
367 set bpframe_lasty
[lindex $bbox 3]
369 .breakpoints.c configure
-width [lindex $bbox 2]
372 # Delete a breakpoint frame
374 proc delete_breakpoint_frame bpnum
{
377 if {![winfo exists .breakpoints
]} return
379 # First, clear the canvas
381 .breakpoints.c delete all
383 # Now, repopulate it with all but the doomed breakpoint
386 foreach bp
[gdb_get_breakpoint_list
] {
388 add_breakpoint_frame
$bp
393 proc asm_win_name
{funcname
} {
394 if {$funcname == "*None*"} {return .asm.
text}
396 regsub -all {\.
} $funcname _ temp
398 return .asm.func_
${temp
}
404 # create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
408 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
409 # land of breakpoint creation. This consists of recording the file and
410 # line number in the breakpoint_file and breakpoint_line arrays. Also,
411 # if there is already a window associated with FILE, it is updated with
415 proc create_breakpoint
{bpnum
file line pc
} {
417 global breakpoint_file
418 global breakpoint_line
419 global pos_to_breakpoint
420 global pos_to_bpcount
424 # Record breakpoint locations
426 set breakpoint_file
($bpnum) $file
427 set breakpoint_line
($bpnum) $line
428 set pos_to_breakpoint
($file:$line) $bpnum
429 if {![info exists pos_to_bpcount
($file:$line)]} {
430 set pos_to_bpcount
($file:$line) 0
432 incr pos_to_bpcount
($file:$line)
433 set pos_to_breakpoint
($pc) $bpnum
434 if {![info exists pos_to_bpcount
($pc)]} {
435 set pos_to_bpcount
($pc) 0
437 incr pos_to_bpcount
($pc)
439 # If there's a window for this file, update it
441 if {[info exists wins
($file)]} {
442 insert_breakpoint_tag
$wins($file) $line
445 # If there's an assembly window, update that too
447 set win
[asm_win_name
$cfunc]
448 if {[winfo exists
$win]} {
449 insert_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
452 # Update the breakpoints window
454 add_breakpoint_frame
$bpnum
460 # delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land
464 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
465 # land of breakpoint destruction. This consists of removing the file and
466 # line number from the breakpoint_file and breakpoint_line arrays. Also,
467 # if there is already a window associated with FILE, the tags are removed
471 proc delete_breakpoint
{bpnum
file line pc
} {
473 global breakpoint_file
474 global breakpoint_line
475 global pos_to_breakpoint
476 global pos_to_bpcount
479 # Save line number and file for later
481 set line
$breakpoint_line($bpnum)
483 set file $breakpoint_file($bpnum)
485 # Reset breakpoint annotation info
487 if {$pos_to_bpcount($file:$line) > 0} {
488 decr pos_to_bpcount
($file:$line)
490 if {$pos_to_bpcount($file:$line) == 0} {
491 catch "unset pos_to_breakpoint($file:$line)"
493 unset breakpoint_file
($bpnum)
494 unset breakpoint_line
($bpnum)
496 # If there's a window for this file, update it
498 if {[info exists wins
($file)]} {
499 delete_breakpoint_tag
$wins($file) $line
504 # If there's an assembly window, update that too
506 if {$pos_to_bpcount($pc) > 0} {
507 decr pos_to_bpcount
($pc)
509 if {$pos_to_bpcount($pc) == 0} {
510 catch "unset pos_to_breakpoint($pc)"
512 set win
[asm_win_name
$cfunc]
513 if {[winfo exists
$win]} {
514 delete_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
519 delete_breakpoint_frame
$bpnum
525 # enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
529 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
530 # land of a breakpoint being enabled. This consists of unstippling the
531 # specified breakpoint indicator.
534 proc enable_breakpoint
{bpnum
file line pc
} {
539 if {[info exists wins
($file)]} {
540 $wins($file) tag configure
$line -fgstipple {}
543 # If there's an assembly window, update that too
545 set win
[asm_win_name
$cfunc]
546 if {[winfo exists
$win]} {
547 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple {}
550 # If there's a breakpoint window, update that too
552 if {[winfo exists .breakpoints
]} {
553 set enabled
($bpnum) 1
560 # disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
564 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
565 # land of a breakpoint being disabled. This consists of stippling the
566 # specified breakpoint indicator.
569 proc disable_breakpoint
{bpnum
file line pc
} {
574 if {[info exists wins
($file)]} {
575 $wins($file) tag configure
$line -fgstipple gray50
578 # If there's an assembly window, update that too
580 set win
[asm_win_name
$cfunc]
581 if {[winfo exists
$win]} {
582 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple gray50
585 # If there's a breakpoint window, update that too
587 if {[winfo exists .breakpoints
]} {
588 set enabled
($bpnum) 0
595 # insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN.
599 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a
600 # breakpoint tag into window WIN at line LINE.
603 proc insert_breakpoint_tag
{win line
} {
604 $win configure
-state normal
606 $win insert
$line.0 "B"
607 $win tag add
$line $line.0
608 $win tag add delete
$line.0 "$line.0 lineend"
609 $win tag add margin
$line.0 "$line.0 lineend"
611 $win configure
-state disabled
617 # delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN.
621 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a
622 # breakpoint tag from window WIN at line LINE.
625 proc delete_breakpoint_tag
{win line
} {
626 $win configure
-state normal
628 if {[string range
$win 0 3] == ".src"} then
{
629 $win insert
$line.0 "\xa4"
631 $win insert
$line.0 " "
633 $win tag delete
$line
634 $win tag add delete
$line.0 "$line.0 lineend"
635 $win tag add margin
$line.0 "$line.0 lineend"
636 $win configure
-state disabled
639 proc gdbtk_tcl_busy
{} {
640 if {[winfo exists .src
]} {
641 .src.start configure
-state disabled
642 .src.stop configure
-state normal
643 .src.step configure
-state disabled
644 .src.next configure
-state disabled
645 .src.
continue configure
-state disabled
646 .src.finish configure
-state disabled
647 .src.up configure
-state disabled
648 .src.down configure
-state disabled
649 .src.bottom configure
-state disabled
651 if {[winfo exists .asm
]} {
652 .asm.stepi configure
-state disabled
653 .asm.nexti configure
-state disabled
654 .asm.
continue configure
-state disabled
655 .asm.finish configure
-state disabled
656 .asm.up configure
-state disabled
657 .asm.down configure
-state disabled
658 .asm.bottom configure
-state disabled
663 proc gdbtk_tcl_idle
{} {
664 if {[winfo exists .src
]} {
665 .src.start configure
-state normal
666 .src.stop configure
-state disabled
667 .src.step configure
-state normal
668 .src.next configure
-state normal
669 .src.
continue configure
-state normal
670 .src.finish configure
-state normal
671 .src.up configure
-state normal
672 .src.down configure
-state normal
673 .src.bottom configure
-state normal
676 if {[winfo exists .asm
]} {
677 .asm.stepi configure
-state normal
678 .asm.nexti configure
-state normal
679 .asm.
continue configure
-state normal
680 .asm.finish configure
-state normal
681 .asm.up configure
-state normal
682 .asm.down configure
-state normal
683 .asm.bottom configure
-state normal
691 # pc_to_line (pclist pc) - convert PC to a line number.
695 # Convert PC to a line number from PCLIST. If exact line isn't found,
696 # we return the first line that starts before PC.
698 proc pc_to_line
{pclist pc
} {
699 set line
[lsearch -exact $pclist $pc]
701 if {$line >= 1} { return $line }
704 foreach linepc
[lrange $pclist 1 end
] {
705 if {$pc < $linepc} { decr line
; return $line }
708 return [expr {$line - 1}]
714 # file popup menu - Define the file popup menu.
718 # This menu just contains a bunch of buttons that do various things to
719 # the line under the cursor.
723 # Edit - Run the editor (specified by the environment variable EDITOR) on
724 # this file, at the current line.
725 # Breakpoint - Set a breakpoint at the current line. This just shoves
726 # a `break' command at GDB with the appropriate file and line
727 # number. Eventually, GDB calls us back (at gdbtk_tcl_breakpoint)
728 # to notify us of where the breakpoint needs to show up.
731 menu .file_popup
-cursor hand2
-tearoff 0
732 .file_popup add command
-label "Not yet set" -state disabled
733 .file_popup add separator
734 .file_popup add command
-label "Edit" \
735 -command {exec $editor +$selected_line $selected_file &}
736 .file_popup add command
-label "Set breakpoint" \
737 -command {gdb_cmd
"break $selected_file:$selected_line"}
739 # Use this procedure to get the GDB core to execute the string `cmd'. This is
740 # a wrapper around gdb_cmd, which will catch errors, and send output to the
741 # command window. It will also cause all of the other windows to be updated.
743 proc interactive_cmd
{cmd
} {
744 catch {gdb_cmd
"$cmd"} result
745 .cmd.
text insert end
$result
753 # file popup menu - Define the file popup menu bindings.
757 # This defines the binding for the file popup menu. It simply
758 # unhighlights the line under the cursor.
761 bind .file_popup
<Any-ButtonRelease-1
> {
763 # Unhighlight the selected line
764 $selected_win tag delete breaktag
770 # file_popup_menu (win x y xrel yrel) - Popup the file popup menu.
774 # This procedure is invoked as a result of a command binding in the
775 # listing window. It does several things:
776 # o - It highlights the line under the cursor.
777 # o - It pops up the file popup menu which is intended to do
778 # various things to the aforementioned line.
779 # o - Grabs the mouse for the file popup menu.
782 # Button 1 has been pressed in a listing window. Pop up a menu.
784 proc file_popup_menu
{win x y xrel yrel
} {
787 global file_to_debug_file
793 # Map TK window name back to file name.
795 set file $win_to_file($win)
797 set pos
[$win index
@$xrel,$yrel]
799 # Record selected file and line for menu button actions
801 set selected_file
$file_to_debug_file($file)
802 set selected_line
[lindex [split $pos .
] 0]
803 set selected_win
$win
805 # Highlight the selected line
807 eval $win tag config breaktag
$highlight
808 $win tag add breaktag
"$pos linestart" "$pos linestart + 1l"
810 # Post the menu near the pointer, (and grab it)
812 .file_popup entryconfigure
0 -label "$selected_file:$selected_line"
813 tk_popup .file_popup
$x $y
819 # listing_window_button_1 (win x y xrel yrel) - Handle button 1 in listing window
823 # This procedure is invoked as a result of holding down button 1 in the
824 # listing window. The action taken depends upon where the button was
825 # pressed. If it was in the left margin (the breakpoint column), it
826 # sets or clears a breakpoint. In the main text area, it will pop up a
830 proc listing_window_button_1
{win x y xrel yrel
} {
833 global file_to_debug_file
838 global pos_to_breakpoint
840 # Map TK window name back to file name.
842 set file $win_to_file($win)
844 set pos
[split [$win index
@$xrel,$yrel] .
]
846 # Record selected file and line for menu button actions
848 set selected_file
$file_to_debug_file($file)
849 set selected_line
[lindex $pos 0]
850 set selected_col
[lindex $pos 1]
851 set selected_win
$win
853 # If we're in the margin, then toggle the breakpoint
855 if {$selected_col < 8} {
856 set pos_break
$selected_file:$selected_line
857 set pos
$file:$selected_line
858 set tmp pos_to_breakpoint
($pos)
859 if {[info exists
$tmp]} {
861 gdb_cmd
"delete $bpnum"
863 gdb_cmd
"break $pos_break"
868 # Post the menu near the pointer, (and grab it)
870 .file_popup entryconfigure
0 -label "$selected_file:$selected_line"
872 tk_popup .file_popup
$x $y
878 # asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window
882 # This procedure is invoked as a result of holding down button 1 in the
883 # assembly window. The action taken depends upon where the button was
884 # pressed. If it was in the left margin (the breakpoint column), it
885 # sets or clears a breakpoint. In the main text area, it will pop up a
889 proc asm_window_button_1
{win x y xrel yrel
} {
892 global file_to_debug_file
897 global pos_to_breakpoint
901 set pos
[split [$win index
@$xrel,$yrel] .
]
903 # Record selected file and line for menu button actions
905 set selected_line
[lindex $pos 0]
906 set selected_col
[lindex $pos 1]
907 set selected_win
$win
911 set pc
[lindex $pclist($cfunc) $selected_line]
913 # If we're in the margin, then toggle the breakpoint
915 if {$selected_col < 11} {
916 set tmp pos_to_breakpoint
($pc)
917 if {[info exists
$tmp]} {
919 gdb_cmd
"delete $bpnum"
926 # Post the menu near the pointer, (and grab it)
928 # .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
929 # .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
936 # do_nothing - Does absolutely nothing.
940 # This procedure does nothing. It is used as a placeholder to allow
941 # the disabling of bindings that would normally be inherited from the
942 # parent widget. I can't think of any other way to do this.
945 proc do_nothing
{} {}
950 # not_implemented_yet - warn that a feature is unavailable
954 # This procedure warns that something doesn't actually work yet.
957 proc not_implemented_yet
{message} {
958 tk_dialog .unimpl
"gdb : unimpl" \
959 "$message: not implemented in the interface yet" \
966 # create_expr_window - Create expression display window
970 # Create the expression display window.
974 set delete_expr_num
0
976 # Set delete_expr_num, and set -state of Delete button.
977 proc expr_update_button
{num
} {
978 global delete_expr_num
979 set delete_expr_num
$num
985 .
expr.buts.delete configure
-state $state
988 proc add_expr
{expr} {
989 global expr_update_list
997 checkbutton $e.updates.
$f -text "" -relief flat
\
998 -variable expr_update_list
($expr_num)
999 text $e.expressions.
$f -width 20 -height 1
1000 $e.expressions.
$f insert
0.0 $expr
1001 bind $e.expressions.
$f <1> "update_expr $expr_num"
1002 text $e.values.
$f -width 20 -height 1
1004 # Set up some bindings.
1005 foreach frame {updates expressions values
} {
1006 bind $e.
$frame.
$f <FocusIn
> "expr_update_button $expr_num"
1007 bind $e.
$frame.
$f <FocusOut
> "expr_update_button 0"
1010 update_expr
$expr_num
1012 pack $e.updates.
$f -side top
1013 pack $e.expressions.
$f -side top
-expand yes
-fill x
1014 pack $e.values.
$f -side top
-expand yes
-fill x
1017 proc delete_expr
{} {
1018 global delete_expr_num
1019 if {$delete_expr_num > 0} then
{
1021 set f e
${delete_expr_num
}
1023 destroy $e.updates.
$f $e.expressions.
$f $e.values.
$f
1025 # FIXME should we unset an element of expr_update_list here?
1029 proc update_expr
{expr_num
} {
1030 global expr_update_list
1035 set expr [$e.expressions.
$f get
0.0 end
]
1036 $e.values.
$f delete
0.0 end
1037 if {! [catch {gdb_eval
$expr} val
]} {
1038 $e.values.
$f insert
0.0 $val
1040 # FIXME consider flashing widget here.
1044 proc update_exprs
{} {
1045 global expr_update_list
1047 foreach expr_num
[array names expr_update_list
] {
1048 if {$expr_update_list($expr_num)} {
1049 update_expr
$expr_num
1054 proc create_expr_window
{} {
1056 if {[winfo exists .
expr]} {raise .
expr ; return}
1059 wm title .
expr "GDB Expressions"
1060 wm iconname .
expr "Expressions"
1062 frame .
expr.entryframe
-borderwidth 2 -relief raised
1063 label .
expr.entryframe.entrylab
-text "Expression: "
1064 entry .
expr.entryframe.
entry -borderwidth 2 -relief sunken
1065 bind .
expr.entryframe.
entry <Return
> {
1066 add_expr
[.
expr.entryframe.
entry get
]
1067 .
expr.entryframe.
entry delete
0 end
1070 pack .
expr.entryframe.entrylab
-side left
1071 pack .
expr.entryframe.
entry -side left
-fill x
-expand yes
1073 frame .
expr.buts
-borderwidth 2 -relief raised
1075 button .
expr.buts.delete
-text Delete
-command delete_expr
\
1078 button .
expr.buts.
close -text Close
-command {destroy .
expr}
1079 button .
expr.buts.help
-text Help
-state disabled
1081 pack .
expr.buts.delete
-side left
1082 pack .
expr.buts.help .
expr.buts.
close -side right
1084 pack .
expr.buts
-side bottom
-fill x
1085 pack .
expr.entryframe
-side bottom
-fill x
1087 frame .
expr.exprs
-borderwidth 2 -relief raised
1089 # Use three subframes so columns will line up. Easier than
1090 # dealing with BLT for a table geometry manager. Someday Tk
1091 # will have one, use it then. FIXME this messes up keyboard
1093 frame .
expr.exprs.updates
-borderwidth 0 -relief flat
1094 frame .
expr.exprs.expressions
-borderwidth 0 -relief flat
1095 frame .
expr.exprs.values
-borderwidth 0 -relief flat
1097 label .
expr.exprs.updates.
label -text Update
1098 pack .
expr.exprs.updates.
label -side top
-anchor w
1099 label .
expr.exprs.expressions.
label -text Expression
1100 pack .
expr.exprs.expressions.
label -side top
-anchor w
1101 label .
expr.exprs.values.
label -text Value
1102 pack .
expr.exprs.values.
label -side top
-anchor w
1104 pack .
expr.exprs.updates
-side left
1105 pack .
expr.exprs.values .
expr.exprs.expressions
\
1106 -side right
-expand 1 -fill x
1108 pack .
expr.exprs
-side top
-fill both
-expand 1 -anchor w
1114 # display_expression (expression) - Display EXPRESSION in display window
1118 # Display EXPRESSION and its value in the expression display window.
1121 proc display_expression
{expression
} {
1124 add_expr
$expression
1130 # create_file_win (filename) - Create a win for FILENAME.
1134 # The new text widget.
1138 # This procedure creates a text widget for FILENAME. It returns the
1139 # newly created widget. First, a text widget is created, and given basic
1140 # configuration info. Second, all the bindings are setup. Third, the
1141 # file FILENAME is read into the text widget. Fourth, margins and line
1142 # numbers are added.
1145 proc create_file_win
{filename debug_file
} {
1146 global breakpoint_file
1147 global breakpoint_line
1150 # Replace all the dirty characters in $filename with clean ones, and generate
1151 # a unique name for the text widget.
1153 regsub -all {\.
} $filename {} temp
1154 set win .src.
text$temp
1156 # Open the file, and read it into the text widget
1158 if {[catch "open $filename" fh
]} {
1159 # File can't be read. Put error message into .src.nofile window and return.
1161 catch {destroy .src.nofile
}
1162 text .src.nofile
-height 25 -width 88 -relief sunken
\
1163 -borderwidth 2 -yscrollcommand ".src.scroll set" \
1164 -setgrid true
-cursor hand2
1165 .src.nofile insert
0.0 $fh
1166 .src.nofile configure
-state disabled
1167 bind .src.nofile
<1> do_nothing
1168 bind .src.nofile
<B1-Motion
> do_nothing
1172 # Actually create and do basic configuration on the text widget.
1174 text $win -height 25 -width 88 -relief sunken
-borderwidth 2 \
1175 -yscrollcommand ".src.scroll set" -setgrid true
-cursor hand2
1177 # Setup all the bindings
1179 bind $win <Enter
> {focus %W
}
1180 bind $win <1> do_nothing
1181 bind $win <B1-Motion
> do_nothing
1183 bind $win <Key-Alt_R
> do_nothing
1184 bind $win <Key-Alt_L
> do_nothing
1185 bind $win <Key-Prior
> "$win yview {@0,0 - 10 lines}"
1186 bind $win <Key-Next
> "$win yview {@0,0 + 10 lines}"
1187 bind $win <Key-Up
> "$win yview {@0,0 - 1 lines}"
1188 bind $win <Key-Down
> "$win yview {@0,0 + 1 lines}"
1189 bind $win <Key-Home
> {update_listing
[gdb_loc
]}
1190 bind $win <Key-End
> "$win see end"
1192 bind $win n
{interactive_cmd next
}
1193 bind $win s
{interactive_cmd step
}
1194 bind $win c
{interactive_cmd
continue}
1195 bind $win f
{interactive_cmd finish
}
1196 bind $win u
{interactive_cmd up
}
1197 bind $win d
{interactive_cmd down
}
1200 $win insert
0.0 [read $fh]
1203 # Add margins (for annotations) and a line number to each line (if requested)
1205 set numlines
[$win index end
]
1206 set numlines
[lindex [split $numlines .
] 0]
1207 if {$line_numbers} {
1208 for {set i
1} {$i <= $numlines} {incr i
} {
1209 $win insert
$i.0 [format " %4d " $i]
1210 $win tag add
source $i.8 "$i.0 lineend"
1213 for {set i
1} {$i <= $numlines} {incr i
} {
1214 $win insert
$i.0 " "
1215 $win tag add
source $i.8 "$i.0 lineend"
1221 foreach i
[gdb_sourcelines
$debug_file] {
1223 $win insert
$i.0 "\xa4"
1224 $win tag add margin
$i.0 $i.8
1227 $win tag
bind margin
<1> {listing_window_button_1
%W
%X
%Y
%x
%y
}
1228 $win tag
bind source <1> {
1229 %W mark
set anchor
"@%x,%y wordstart"
1230 set last
[%W index
"@%x,%y wordend"]
1231 %W tag remove sel
0.0 anchor
1232 %W tag remove sel
$last end
1233 %W tag add sel anchor
$last
1235 # $win tag bind source <Double-Button-1> {
1236 # %W mark set anchor "@%x,%y wordstart"
1237 # set last [%W index "@%x,%y wordend"]
1238 # %W tag remove sel 0.0 anchor
1239 # %W tag remove sel $last end
1240 # %W tag add sel anchor $last
1241 # echo "Selected [selection get]"
1243 $win tag
bind source <B1-Motion
> {
1244 %W tag remove sel
0.0 anchor
1245 %W tag remove sel
$last end
1246 %W tag add sel anchor
@%x
,%y
1248 $win tag
bind sel
<1> do_nothing
1249 $win tag
bind sel
<Double-Button-1
> {display_expression
[selection get
]}
1253 # Scan though the breakpoint data base and install any destined for this file
1255 foreach bpnum
[array names breakpoint_file
] {
1256 if {$breakpoint_file($bpnum) == $filename} {
1257 insert_breakpoint_tag
$win $breakpoint_line($bpnum)
1261 # Disable the text widget to prevent user modifications
1263 $win configure
-state disabled
1270 # create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
1274 # The new text widget.
1278 # This procedure creates a text widget for FUNCNAME. It returns the
1279 # newly created widget. First, a text widget is created, and given basic
1280 # configuration info. Second, all the bindings are setup. Third, the
1281 # function FUNCNAME is read into the text widget.
1284 proc create_asm_win
{funcname pc
} {
1285 global breakpoint_file
1286 global breakpoint_line
1288 global disassemble_with_source
1290 # Replace all the dirty characters in $filename with clean ones, and generate
1291 # a unique name for the text widget.
1293 set win
[asm_win_name
$funcname]
1295 # Actually create and do basic configuration on the text widget.
1297 text $win -height 25 -width 80 -relief sunken
-borderwidth 2 \
1298 -setgrid true
-cursor hand2
-yscrollcommand ".asm.scroll set"
1300 # Setup all the bindings
1302 bind $win <Enter
> {focus %W
}
1303 bind $win <1> {asm_window_button_1
%W
%X
%Y
%x
%y
}
1304 bind $win <B1-Motion
> do_nothing
1306 bind $win <Key-Alt_R
> do_nothing
1307 bind $win <Key-Alt_L
> do_nothing
1309 bind $win n
{interactive_cmd nexti
}
1310 bind $win s
{interactive_cmd stepi
}
1311 bind $win c
{interactive_cmd
continue}
1312 bind $win f
{interactive_cmd finish
}
1313 bind $win u
{interactive_cmd up
}
1314 bind $win d
{interactive_cmd down
}
1316 # Disassemble the code, and read it into the new text widget
1318 $win insert end
[gdb_disassemble
$disassemble_with_source $pc]
1320 set numlines
[$win index end
]
1321 set numlines
[lindex [split $numlines .
] 0]
1324 # Delete the first and last lines, cuz these contain useless info
1326 # $win delete 1.0 2.0
1327 # $win delete {end - 1 lines} end
1330 # Add margins (for annotations) and note the PC for each line
1332 catch "unset pclist($funcname)"
1333 lappend pclist
($funcname) Unused
1334 for {set i
1} {$i <= $numlines} {incr i
} {
1335 scan [$win get
$i.0 "$i.0 lineend"] "%s " pc
1336 lappend pclist
($funcname) $pc
1337 $win insert
$i.0 " "
1340 # Scan though the breakpoint data base and install any destined for this file
1342 # foreach bpnum [array names breakpoint_file] {
1343 # if {$breakpoint_file($bpnum) == $filename} {
1344 # insert_breakpoint_tag $win $breakpoint_line($bpnum)
1348 # Disable the text widget to prevent user modifications
1350 $win configure
-state disabled
1357 # update_listing (linespec) - Update the listing window according to
1362 # This procedure is called from various places to update the listing
1363 # window based on LINESPEC. It is usually invoked with the result of
1366 # It will move the cursor, and scroll the text widget if necessary.
1367 # Also, it will switch to another text widget if necessary, and update
1368 # the label widget too.
1370 # LINESPEC is a list of the form:
1372 # { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
1374 # DEBUG_FILE - is the abbreviated form of the file name. This is usually
1375 # the file name string given to the cc command. This is
1376 # primarily needed for breakpoint commands, and when an
1377 # abbreviated for of the filename is desired.
1378 # FUNCNAME - is the name of the function.
1379 # FILENAME - is the fully qualified (absolute) file name. It is usually
1380 # the same as $PWD/$DEBUG_FILE, where PWD is the working dir
1381 # at the time the cc command was given. This is used to
1382 # actually locate the file to be displayed.
1383 # LINE - The line number to be displayed.
1385 # Usually, this procedure will just move the cursor one line down to the
1386 # next line to be executed. However, if the cursor moves out of range
1387 # or into another file, it will scroll the text widget so that the line
1388 # of interest is in the middle of the viewable portion of the widget.
1391 proc update_listing
{linespec
} {
1394 global current_label
1396 global file_to_debug_file
1399 # Rip the linespec apart
1401 lassign
$linespec debug_file funcname
filename line
1403 # Sometimes there's no source file for this location
1405 if {$filename == ""} {set filename Blank
}
1407 # If we want to switch files, we need to unpack the current text widget, and
1408 # stick in the new one.
1410 if {$filename != $cfile} then
{
1411 pack forget
$wins($cfile)
1414 # Create a text widget for this file if necessary
1416 if {![info exists wins
($cfile)]} then
{
1417 set wins
($cfile) [create_file_win
$cfile $debug_file]
1418 if {$wins($cfile) != ".src.nofile"} {
1419 set win_to_file
($wins($cfile)) $cfile
1420 set file_to_debug_file
($cfile) $debug_file
1421 set pointers
($cfile) 1.1
1425 # Pack the text widget into the listing widget, and scroll to the right place
1427 pack $wins($cfile) -side left
-expand yes
-in .src.
info \
1428 -fill both
-after .src.scroll
1430 # Make the scrollbar point at the new text widget
1432 .src.scroll configure
-command "$wins($cfile) yview"
1434 $wins($cfile) see
"${line}.0 linestart"
1437 # Update the label widget in case the filename or function name has changed
1439 if {$current_label != "$filename.$funcname"} then
{
1440 set tail
[expr [string last
/ $filename] + 1]
1441 set .src.
label "[string range $filename $tail end] : ${funcname}()"
1442 # .src.label configure -text "[string range $filename $tail end] : ${funcname}()"
1443 set current_label
$filename.
$funcname
1446 # Update the pointer, scrolling the text widget if necessary to keep the
1447 # pointer in an acceptable part of the screen.
1449 if {[info exists pointers
($cfile)]} then
{
1450 $wins($cfile) configure
-state normal
1451 set pointer_pos
$pointers($cfile)
1452 $wins($cfile) configure
-state normal
1453 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1454 $wins($cfile) insert
$pointer_pos " "
1456 set pointer_pos
[$wins($cfile) index
$line.1]
1457 set pointers
($cfile) $pointer_pos
1459 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1460 $wins($cfile) insert
$pointer_pos "->"
1461 $wins($cfile) see
"${line}.0 linestart"
1462 $wins($cfile) configure
-state disabled
1469 # create_asm_window - Open up the assembly window.
1473 # Create an assembly window if it doesn't exist.
1476 proc create_asm_window
{} {
1479 if {[winfo exists .asm
]} {raise .asm
; return}
1482 set win
[asm_win_name
$cfunc]
1484 build_framework .asm Assembly
"*NIL*"
1486 # First, delete all the old menu entries
1488 .asm.menubar.view.
menu delete
0 last
1490 .asm.
text configure
-yscrollcommand ".asm.scroll set"
1495 button .asm.stepi
-width 6 -text Stepi
\
1496 -command {interactive_cmd stepi
}
1497 button .asm.nexti
-width 6 -text Nexti
\
1498 -command {interactive_cmd nexti
}
1499 button .asm.
continue -width 6 -text Cont
\
1500 -command {interactive_cmd
continue}
1501 button .asm.finish
-width 6 -text Finish
\
1502 -command {interactive_cmd finish
}
1503 button .asm.up
-width 6 -text Up
-command {interactive_cmd up
}
1504 button .asm.down
-width 6 -text Down
\
1505 -command {interactive_cmd down
}
1506 button .asm.bottom
-width 6 -text Bottom
\
1507 -command {interactive_cmd
{frame 0}}
1509 pack .asm.stepi .asm.
continue .asm.up .asm.bottom
-side left
-padx 3 -pady 5 -in .asm.row1
1510 pack .asm.nexti .asm.finish .asm.down
-side left
-padx 3 -pady 5 -in .asm.row2
1512 pack .asm.row2 .asm.row1
-side bottom
-anchor w
-before .asm.
info
1516 update_assembly
[gdb_loc
]
1518 # We do this update_assembly to get the proper value of disassemble-from-exec.
1520 # exec file menu item
1521 .asm.menubar.view.
menu add
radiobutton -label "Exec file" \
1522 -variable disassemble-from-exec
-value 1
1523 # target memory menu item
1524 .asm.menubar.view.
menu add
radiobutton -label "Target memory" \
1525 -variable disassemble-from-exec
-value 0
1527 # Disassemble with source
1528 .asm.menubar.view.
menu add
checkbutton -label "Source" \
1529 -variable disassemble_with_source
-onvalue source \
1530 -offvalue nosource
-command {
1531 foreach asm
[info command .asm.func_
*] {
1535 update_assembly
[gdb_loc
]
1539 proc reg_config_menu
{} {
1540 catch {destroy .reg.config
}
1541 toplevel .reg.config
1542 wm geometry .reg.config
+300+300
1543 wm title .reg.config
"Register configuration"
1544 wm iconname .reg.config
"Reg config"
1545 set regnames
[gdb_regnames
]
1546 set num_regs
[llength $regnames]
1548 frame .reg.config.buts
1550 button .reg.config.done
-text " Done " -command "
1551 recompute_reg_display_list $num_regs
1553 update_registers all
1554 destroy .reg.config "
1556 button .reg.config.
update -text Update
-command "
1557 recompute_reg_display_list $num_regs
1559 update_registers all "
1561 pack .reg.config.buts
-side bottom
-fill x
1563 pack .reg.config.done
-side left
-fill x
-expand yes
-in .reg.config.buts
1564 pack .reg.config.
update -side right
-fill x
-expand yes
-in .reg.config.buts
1566 # Since there can be lots of registers, we build the window with no more than
1567 # 32 rows, and as many columns as needed.
1569 # First, figure out how many columns we need and create that many column frame
1572 set ncols
[expr ($num_regs + 31) / 32]
1574 for {set col
0} {$col < $ncols} {incr col
} {
1575 frame .reg.config.col
$col
1576 pack .reg.config.col
$col -side left
-anchor n
1579 # Now, create the checkbutton widgets and pack them in the appropriate columns
1583 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1584 set regname
[lindex $regnames $regnum]
1585 checkbutton .reg.config.col
$col.
$row -text $regname -pady 0 \
1586 -variable regena
($regnum) -relief flat
-anchor w
-bd 1
1588 pack .reg.config.col
$col.
$row -side top
-fill both
1601 # create_registers_window - Open up the register display window.
1605 # Create the register display window, with automatic updates.
1608 proc create_registers_window
{} {
1611 if {[winfo exists .reg
]} {raise .reg
; return}
1613 # Create an initial register display list consisting of all registers
1615 if {![info exists reg_format
]} {
1616 global reg_display_list
1617 global changed_reg_list
1621 set num_regs
[llength [gdb_regnames
]]
1622 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1623 set regena
($regnum) 1
1625 recompute_reg_display_list
$num_regs
1626 set changed_reg_list
$reg_display_list
1629 build_framework .reg Registers
1631 # First, delete all the old menu entries
1633 .reg.menubar.view.
menu delete
0 last
1636 .reg.menubar.view.
menu add
radiobutton -label Hex
\
1637 -command {set reg_format x
; update_registers all
}
1640 .reg.menubar.view.
menu add
radiobutton -label Decimal
\
1641 -command {set reg_format d
; update_registers all
}
1644 .reg.menubar.view.
menu add
radiobutton -label Octal
\
1645 -command {set reg_format o
; update_registers all
}
1648 .reg.menubar.view.
menu add
radiobutton -label Natural
\
1649 -command {set reg_format
{} ; update_registers all
}
1652 .reg.menubar.view.
menu add separator
1654 .reg.menubar.view.
menu add command
-label Config
-command {
1659 # Install the reg names
1662 update_registers all
1665 # Convert regena into a list of the enabled $regnums
1667 proc recompute_reg_display_list
{num_regs
} {
1668 global reg_display_list
1672 catch {unset reg_display_list
}
1675 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1677 if {[set regena
($regnum)] != 0} {
1678 lappend reg_display_list
$regnum
1679 set regmap
($regnum) $line
1685 # Fill out the register window with the names of the regs specified in
1688 proc populate_reg_window
{} {
1689 global max_regname_width
1690 global reg_display_list
1692 .reg.
text configure
-state normal
1694 .reg.
text delete
0.0 end
1696 set regnames
[eval gdb_regnames
$reg_display_list]
1698 # Figure out the longest register name
1700 set max_regname_width
0
1702 foreach reg
$regnames {
1703 set len
[string length
$reg]
1704 if {$len > $max_regname_width} {set max_regname_width
$len}
1707 set width
[expr $max_regname_width + 15]
1709 set height
[llength $regnames]
1711 if {$height > 60} {set height
60}
1713 .reg.
text configure
-height $height -width $width
1715 foreach reg
$regnames {
1716 .reg.
text insert end
[format "%-*s \n" $max_regname_width ${reg
}]
1720 .reg.
text configure
-state disabled
1726 # update_registers - Update the registers window.
1730 # This procedure updates the registers window.
1733 proc update_registers
{which
} {
1734 global max_regname_width
1736 global reg_display_list
1737 global changed_reg_list
1741 set margin
[expr $max_regname_width + 1]
1743 set winwidth
[lindex [$win configure
-width] 4]
1744 set valwidth
[expr $winwidth - $margin]
1746 $win configure
-state normal
1748 if {$which == "all"} {
1750 foreach regnum
$reg_display_list {
1751 set regval
[gdb_fetch_registers
$reg_format $regnum]
1752 set regval
[format "%-*s" $valwidth $regval]
1753 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
1754 $win insert
$lineindex.
$margin $regval
1757 $win configure
-state disabled
1761 # Unhighlight the old values
1763 foreach regnum
$changed_reg_list {
1764 $win tag delete
$win.
$regnum
1767 # Now, highlight the changed values of the interesting registers
1769 set changed_reg_list
[eval gdb_changed_register_list
$reg_display_list]
1772 foreach regnum
$changed_reg_list {
1773 set regval
[gdb_fetch_registers
$reg_format $regnum]
1774 set regval
[format "%-*s" $valwidth $regval]
1776 set lineindex
$regmap($regnum)
1777 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
1778 $win insert
$lineindex.
$margin $regval
1779 $win tag add
$win.
$regnum $lineindex.0 "$lineindex.0 lineend"
1780 eval $win tag configure
$win.
$regnum $highlight
1783 $win configure
-state disabled
1789 # update_assembly - Update the assembly window.
1793 # This procedure updates the assembly window.
1796 proc update_assembly
{linespec
} {
1799 global current_label
1801 global file_to_debug_file
1802 global current_asm_label
1806 # Rip the linespec apart
1808 lassign
$linespec debug_file funcname
filename line pc
1810 set win
[asm_win_name
$cfunc]
1812 # Sometimes there's no source file for this location
1814 if {$filename == ""} {set filename Blank
}
1816 # If we want to switch funcs, we need to unpack the current text widget, and
1817 # stick in the new one.
1819 if {$funcname != $cfunc } {
1823 set win
[asm_win_name
$cfunc]
1825 # Create a text widget for this func if necessary
1827 if {![winfo exists
$win]} {
1828 create_asm_win
$cfunc $pc
1829 set asm_pointers
($cfunc) 1.1
1830 set current_asm_label NIL
1833 # Pack the text widget, and scroll to the right place
1836 pack $win -side left
-expand yes
-fill both
\
1838 .asm.scroll configure
-command "$win yview"
1839 set line
[pc_to_line
$pclist($cfunc) $pc]
1840 $win see
"${line}.0 linestart"
1844 # Update the label widget in case the filename or function name has changed
1846 if {$current_asm_label != "$pc $funcname"} then
{
1847 set .asm.
label "$pc $funcname"
1848 set current_asm_label
"$pc $funcname"
1851 # Update the pointer, scrolling the text widget if necessary to keep the
1852 # pointer in an acceptable part of the screen.
1854 if {[info exists asm_pointers
($cfunc)]} then
{
1855 $win configure
-state normal
1856 set pointer_pos
$asm_pointers($cfunc)
1857 $win configure
-state normal
1858 $win delete
$pointer_pos "$pointer_pos + 2 char"
1859 $win insert
$pointer_pos " "
1861 # Map the PC back to a line in the window
1863 set line
[pc_to_line
$pclist($cfunc) $pc]
1866 echo
"Can't find PC $pc"
1870 set pointer_pos
[$win index
$line.1]
1871 set asm_pointers
($cfunc) $pointer_pos
1873 $win delete
$pointer_pos "$pointer_pos + 2 char"
1874 $win insert
$pointer_pos "->"
1875 $win yview
"${line}.0 linestart"
1876 $win configure
-state disabled
1883 # update_ptr - Update the listing window.
1887 # This routine will update the listing window using the result of
1891 proc update_ptr
{} {
1892 update_listing
[gdb_loc
]
1893 if {[winfo exists .asm
]} {
1894 update_assembly
[gdb_loc
]
1896 if {[winfo exists .reg
]} {
1897 update_registers changed
1899 if {[winfo exists .
expr]} {
1902 if {[winfo exists .autocmd
]} {
1907 # Make toplevel window disappear
1911 proc files_command
{} {
1912 toplevel .files_window
1914 wm minsize .files_window
1 1
1915 # wm overrideredirect .files_window true
1916 listbox .files_window.
list -geometry 30x20
-setgrid true
\
1917 -yscrollcommand {.files_window.scroll
set} -relief sunken
\
1919 scrollbar .files_window.scroll
-orient vertical
\
1920 -command {.files_window.
list yview
} -relief sunken
1921 button .files_window.
close -text Close
-command {destroy .files_window
}
1922 .files_window.
list configure
-selectmode single
1924 # Get the file list from GDB, sort it, and format it as one entry per line.
1925 set lastSeen
{}; # Value that won't appear in
1928 foreach file [lsort [gdb_listfiles
]] {
1929 if {$file != $lastSeen} then
{
1930 lappend fileList
$file
1934 set filelist
[join [lsort [gdb_listfiles
]] "\n"]
1936 # Insert the file list into the widget
1938 eval .files_window.
list insert
0 $filelist
1940 pack .files_window.
close -side bottom
-fill x
-expand no
-anchor s
1941 pack .files_window.scroll
-side right
-fill both
1942 pack .files_window.
list -side left
-fill both
-expand yes
1943 bind .files_window.
list <Any-ButtonRelease-1
> {
1944 set file [%W get
[%W curselection
]]
1945 gdb_cmd
"list $file:1,0"
1946 update_listing
[gdb_loc
$file:1]
1947 destroy .files_window
1951 button .files
-text Files
-command files_command
1953 proc apply_filespec
{label default command
} {
1954 set filename [FSBox
$label $default]
1955 if {$filename != ""} {
1956 if {[catch {gdb_cmd
"$command $filename"} retval
]} {
1957 tk_dialog .filespec_error
"gdb : $label error" \
1958 "Error in command \"$command $filename\"" error \
1967 proc run_editor
{editor
file} {
1968 # FIXME should use index of line in middle of window, not line at
1971 set lineNo
[lindex [split [$wins($file) index
@0,0] .
] 0]
1972 exec $editor +$lineNo $file
1975 # 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 {run_editor
$editor $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 pack ${win
}.menubar.
file \
2078 ${win
}.menubar.view
\
2079 ${win
}.menubar.window
-side left
2080 pack ${win
}.menubar.help
-side right
2083 text ${win
}.
text -height 25 -width 80 -relief sunken
-borderwidth 2 \
2084 -setgrid true
-cursor hand2
-yscrollcommand "${win}.scroll set"
2086 set ${win
}.
label $label
2087 label ${win
}.
label -textvariable ${win
}.
label -borderwidth 2 -relief sunken
2089 scrollbar ${win
}.scroll
-orient vertical
-command "${win}.text yview" \
2092 bind $win <Key-Alt_R
> do_nothing
2093 bind $win <Key-Alt_L
> do_nothing
2095 pack ${win
}.
label -side bottom
-fill x
-in ${win
}.
info
2096 pack ${win
}.scroll
-side right
-fill y
-in ${win
}.
info
2097 pack ${win
}.
text -side left
-expand yes
-fill both
-in ${win
}.
info
2099 pack ${win
}.menubar
-side top
-fill x
2100 pack ${win
}.
info -side top
-fill both
-expand yes
2103 proc create_source_window
{} {
2107 if {[winfo exists .src
]} {raise .src
; return}
2109 build_framework .src Source
"*No file*"
2111 # First, delete all the old view menu entries
2113 .src.menubar.view.
menu delete
0 last
2115 # Source file selection
2116 .src.menubar.view.
menu add command
-label "Select source file" \
2117 -command files_command
2119 # Line numbers enable/disable menu item
2120 .src.menubar.view.
menu add
checkbutton -variable line_numbers
\
2121 -label "Line numbers" -onvalue 1 -offvalue 0 -command {
2122 foreach source [array names wins
] {
2123 if {$source == "Blank"} continue
2124 destroy $wins($source)
2128 update_listing
[gdb_loc
]
2134 button .src.start
-width 6 -text Start
-command \
2135 {interactive_cmd
{break main
}
2136 interactive_cmd
{enable delete
$bpnum}
2137 interactive_cmd run
}
2138 button .src.stop
-width 6 -text Stop
-fg red
-activeforeground red
\
2139 -state disabled
-command gdb_stop
2140 button .src.step
-width 6 -text Step
\
2141 -command {interactive_cmd step
}
2142 button .src.next
-width 6 -text Next
\
2143 -command {interactive_cmd next
}
2144 button .src.
continue -width 6 -text Cont
\
2145 -command {interactive_cmd
continue}
2146 button .src.finish
-width 6 -text Finish
\
2147 -command {interactive_cmd finish
}
2148 button .src.up
-width 6 -text Up
\
2149 -command {interactive_cmd up
}
2150 button .src.down
-width 6 -text Down
\
2151 -command {interactive_cmd down
}
2152 button .src.bottom
-width 6 -text Bottom
\
2153 -command {interactive_cmd
{frame 0}}
2155 pack .src.start .src.step .src.
continue .src.up .src.bottom
\
2156 -side left
-padx 3 -pady 5 -in .src.row1
2157 pack .src.stop .src.next .src.finish .src.down
-side left
-padx 3 \
2158 -pady 5 -in .src.row2
2160 pack .src.row2 .src.row1
-side bottom
-anchor w
-before .src.
info
2162 $wins($cfile) insert
0.0 " This page intentionally left blank."
2163 $wins($cfile) configure
-width 88 -state disabled
\
2164 -yscrollcommand ".src.scroll set"
2167 proc update_autocmd
{} {
2168 global .autocmd.
label
2169 global accumulate_output
2171 catch {gdb_cmd
"${.autocmd.label}"} result
2172 if {!$accumulate_output} { .autocmd.
text delete
0.0 end
}
2173 .autocmd.
text insert end
$result
2174 .autocmd.
text see end
2177 proc create_autocmd_window
{} {
2178 global .autocmd.
label
2180 if {[winfo exists .autocmd
]} {raise .autocmd
; return}
2182 build_framework .autocmd
"Auto Command" ""
2184 # First, delete all the old view menu entries
2186 .autocmd.menubar.view.
menu delete
0 last
2188 # Accumulate output option
2190 .autocmd.menubar.view.
menu add
checkbutton \
2191 -variable accumulate_output
\
2192 -label "Accumulate output" -onvalue 1 -offvalue 0
2194 # Now, create entry widget with label
2196 frame .autocmd.entryframe
2198 entry .autocmd.
entry -borderwidth 2 -relief sunken
2199 bind .autocmd.
entry <Key-Return
> {
2200 set .autocmd.
label [.autocmd.
entry get
]
2201 .autocmd.
entry delete
0 end
2204 label .autocmd.entrylab
-text "Command: "
2206 pack .autocmd.entrylab
-in .autocmd.entryframe
-side left
2207 pack .autocmd.
entry -in .autocmd.entryframe
-side left
-fill x
-expand yes
2209 pack .autocmd.entryframe
-side bottom
-fill x
-before .autocmd.
info
2212 # Return the longest common prefix in SLIST. Can be empty string.
2214 proc find_lcp slist
{
2215 # Handle trivial cases where list is empty or length 1
2216 if {[llength $slist] <= 1} {return [lindex $slist 0]}
2218 set prefix
[lindex $slist 0]
2219 set prefixlast
[expr [string length
$prefix] - 1]
2221 foreach str
[lrange $slist 1 end
] {
2222 set test_str
[string range
$str 0 $prefixlast]
2223 while {[string compare
$test_str $prefix] != 0} {
2225 set prefix
[string range
$prefix 0 $prefixlast]
2226 set test_str
[string range
$str 0 $prefixlast]
2228 if {$prefixlast < 0} break
2233 # Look through COMPLETIONS to generate the suffix needed to do command
2234 # completion on CMD.
2236 proc find_completion
{cmd completions
} {
2237 # Get longest common prefix
2238 set lcp
[find_lcp
$completions]
2239 set cmd_len
[string length
$cmd]
2240 # Return suffix beyond end of cmd
2241 return [string range
$lcp $cmd_len end
]
2244 proc create_command_window
{} {
2249 if {[winfo exists .cmd
]} {raise .cmd
; return}
2251 build_framework .cmd Command
"* Command Buffer *"
2253 # Put focus on command area.
2258 gdb_cmd
{set language c
}
2259 gdb_cmd
{set height
0}
2260 gdb_cmd
{set width
0}
2262 # Tk uses the Motifism that Delete means delete forward. I
2263 # hate this, and I'm not gonna take it any more.
2264 set bsBinding
[bind Text
<BackSpace
>]
2265 bind .cmd.
text <Delete
> "delete_char %W ; $bsBinding; break"
2266 bind .cmd.
text <BackSpace
> {delete_char
%W
}
2267 bind .cmd.
text <Control-c
> gdb_stop
2268 bind .cmd.
text <Control-u
> {delete_line
%W
; break}
2269 bind .cmd.
text <Any-Key
> {
2273 append command_line
%A
2276 bind .cmd.
text <Key-Return
> {
2279 interactive_cmd
$command_line
2282 # catch "gdb_cmd [list $command_line]" result
2283 # %W insert end $result
2286 %W insert end
"(gdb) "
2290 bind .cmd.
text <Button-2
> {
2291 %W insert end
[selection get
]
2293 append command_line
[selection get
]
2296 bind .cmd.
text <Key-Tab
> {
2297 set choices
[gdb_cmd
"complete $command_line"]
2298 set choices
[string trimright
$choices \n]
2299 set choices
[split $choices \n]
2301 # Just do completion if this is the first tab
2304 set completion
[find_completion
$command_line $choices]
2305 append command_line
$completion
2306 # Here is where the completion is actually done. If there
2307 # is one match, complete the command and print a space.
2308 # If two or more matches, complete the command and beep.
2309 # If no match, just beep.
2310 switch [llength $choices] {
2313 %W insert end
"$completion "
2314 append command_line
" "
2319 %W insert end
$completion
2325 # User hit another consecutive tab. List the choices.
2326 # Note that at this point, choices may contain commands
2327 # with spaces. We have to lop off everything before (and
2328 # including) the last space so that the completion list
2329 # only shows the possibilities for the last token.
2330 set choices
[lsort $choices]
2331 if {[regexp ".* " $command_line prefix
]} {
2332 regsub -all $prefix $choices {} choices
2334 %W insert end
"\n[join $choices { }]\n(gdb) $command_line"
2341 proc delete_char
{win
} {
2343 set tmp
[expr [string length
$command_line] - 2]
2344 set command_line
[string range
$command_line 0 $tmp]
2347 proc delete_line
{win
} {
2350 $win delete
{end linestart
+ 6 chars
} end
2357 # simple file selector.
2359 # Mario Jorge Silva msilva@cs.Berkeley.EDU
2360 # University of California Berkeley Ph: +1(510)642-8248
2361 # Computer Science Division, 571 Evans Hall Fax: +1(510)642-5775
2365 # Copyright 1993 Regents of the University of California
2366 # Permission to use, copy, modify, and distribute this
2367 # software and its documentation for any purpose and without
2368 # fee is hereby granted, provided that this copyright
2369 # notice appears in all copies. The University of California
2370 # makes no representations about the suitability of this
2371 # software for any purpose. It is provided "as is" without
2372 # express or implied warranty.
2376 # names starting with "fileselect" are reserved by this module
2377 # no other names used.
2378 # Hack - FSBox is defined instead of fileselect for backwards compatibility
2381 # this is the proc that creates the file selector box
2382 # purpose - comment string
2383 # defaultName - initial value for name
2384 # cmd - command to eval upon OK
2385 # errorHandler - command to eval upon Cancel
2386 # If neither cmd or errorHandler are specified, the return value
2387 # of the FSBox procedure is the selected file name.
2389 proc FSBox
{{purpose
"Select file:"} {defaultName
""} {cmd
""} {errorHandler
2393 if {[Exwin_Toplevel
$w "Select File" FileSelect
]} {
2394 # path independent names for the widgets
2396 set fileselect
(list) $w.
file.sframe.
list
2397 set fileselect
(scroll
) $w.
file.sframe.scroll
2398 set fileselect
(direntry
) $w.
file.f1.direntry
2399 set fileselect
(entry) $w.
file.f2.
entry
2400 set fileselect
(ok
) $w.but.ok
2401 set fileselect
(cancel
) $w.but.cancel
2402 set fileselect
(msg
) $w.
label
2404 set fileselect
(result
) "" ;# value to return if no callback procedures
2407 Widget_Label
$w label {top fillx pady
10 padx
20} -anchor w
-width 24
2408 Widget_Frame
$w file Dialog
{left expand fill
} -bd 10
2410 Widget_Frame
$w.
file f1 Exmh
{top fillx
}
2411 Widget_Label
$w.
file.f1
label {left
} -text "Dir"
2412 Widget_Entry
$w.
file.f1 direntry
{right fillx expand
} -width 30
2414 Widget_Frame
$w.
file sframe
2416 scrollbar $w.
file.sframe.yscroll
-relief sunken
\
2417 -command [list $w.
file.sframe.
list yview
]
2418 listbox $w.
file.sframe.
list -relief sunken
\
2419 -yscroll [list $w.
file.sframe.yscroll
set] -setgrid 1
2420 pack append $w.
file.sframe
\
2421 $w.
file.sframe.yscroll
{right filly
} \
2422 $w.
file.sframe.
list {left expand fill
}
2424 Widget_Frame
$w.
file f2 Exmh
{top fillx
}
2425 Widget_Label
$w.
file.f2
label {left
} -text Name
2426 Widget_Entry
$w.
file.f2
entry {right fillx expand
}
2429 $w.but.quit configure
-text Cancel
\
2430 -command [list fileselect.cancel.cmd
$w]
2432 Widget_AddBut
$w.but ok OK
\
2433 [list fileselect.ok.cmd
$w $cmd $errorHandler] {left padx
1}
2435 Widget_AddBut
$w.but
list List
\
2436 [list fileselect.
list.cmd
$w] {left padx
1}
2437 Widget_CheckBut
$w.but listall
"List all" fileselect
(pattern
)
2438 $w.but.listall configure
-onvalue "{*,.*}" -offvalue "*" \
2439 -command {fileselect.
list.cmd
$fileselect(direntry
)}
2440 $w.but.listall deselect
2442 # Set up bindings for the browser.
2443 foreach ww
[list $w $fileselect(entry)] {
2444 bind $ww <Return
> [list $fileselect(ok
) invoke
]
2445 bind $ww <Control-c
> [list $fileselect(cancel
) invoke
]
2447 bind $fileselect(direntry
) <Return
> [list fileselect.
list.cmd
%W
]
2448 bind $fileselect(direntry
) <Tab
> [list fileselect.tab.dircmd
]
2449 bind $fileselect(entry) <Tab
> [list fileselect.tab.filecmd
]
2451 $fileselect(list) configure
-selectmode single
2453 bind $fileselect(list) <Button-1
> {
2454 # puts stderr "button 1 release"
2455 $fileselect(entry) delete
0 end
2456 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2459 bind $fileselect(list) <Key
> {
2460 $fileselect(entry) delete
0 end
2461 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2464 bind $fileselect(list) <Double-ButtonPress-1
> {
2465 # puts stderr "double button 1"
2466 $fileselect(entry) delete
0 end
2467 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2468 $fileselect(ok
) invoke
2471 bind $fileselect(list) <Return
> {
2472 $fileselect(entry) delete
0 end
2473 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2474 $fileselect(ok
) invoke
2477 set fileselect
(text) $purpose
2478 $fileselect(msg
) configure
-text $purpose
2479 $fileselect(entry) delete
0 end
2480 $fileselect(entry) insert
0 [file tail
$defaultName]
2482 if {[info exists fileselect
(lastDir
)] && ![string length
$defaultName]} {
2483 set dir
$fileselect(lastDir
)
2485 set dir
[file dirname
$defaultName]
2487 set fileselect
(pwd) [pwd]
2489 $fileselect(direntry
) delete
0 end
2490 $fileselect(direntry
) insert
0 [pwd]/
2492 $fileselect(list) delete
0 end
2493 $fileselect(list) insert
0 "Big directory:"
2494 $fileselect(list) insert
1 $dir
2495 $fileselect(list) insert
2 "Press Return for Listing"
2497 fileselect.
list.cmd
$fileselect(direntry
) startup
2499 # set kbd focus to entry widget
2501 # Exwin_ToplevelFocus $w $fileselect(entry)
2503 # Wait for button hits if no callbacks are defined
2505 if {"$cmd" == "" && "$errorHandler" == ""} {
2506 # wait for the box to be destroyed
2509 tkwait variable fileselect
(result
)
2512 set path
$fileselect(result
)
2513 set fileselect
(lastDir
) [pwd]
2514 fileselect.
cd $fileselect(pwd)
2515 return [string trimright
[string trim
$path] /]
2517 fileselect.
cd $fileselect(pwd)
2521 proc fileselect.
cd { dir
} {
2523 if {[catch {cd $dir} err
]} {
2528 # auxiliary button procedures
2530 proc fileselect.yck
{ {tag
{}} } {
2532 $fileselect(msg
) configure
-text "Yck! $tag"
2535 proc fileselect.ok
{} {
2537 $fileselect(msg
) configure
-text $fileselect(text)
2540 proc fileselect.cancel.cmd
{w
} {
2542 set fileselect
(result
) {}
2546 proc fileselect.
list.cmd
{w
{state normal
}} {
2548 set seldir
[$fileselect(direntry
) get
]
2549 if {[catch {glob $seldir} dir
]} {
2550 fileselect.yck
"glob failed"
2553 if {[llength $dir] > 1} {
2554 set dir
[file dirname
$seldir]
2555 set pat
[file tail
$seldir]
2557 set pat
$fileselect(pattern
)
2561 if {[file isdirectory
$dir]} {
2562 fileselect.getfiles
$dir $pat $state
2563 focus $fileselect(entry)
2565 fileselect.yck
"not a dir"
2569 proc fileselect.ok.cmd
{w cmd errorHandler
} {
2571 set selname
[$fileselect(entry) get
]
2572 set seldir
[$fileselect(direntry
) get
]
2574 if {[string match
/* $selname]} {
2575 set selected
$selname
2577 if {[string match ~
* $selname]} {
2578 set selected
$selname
2580 set selected
$seldir/$selname
2584 # some nasty file names may cause "file isdirectory" to return an error
2585 if {[catch {file isdirectory
$selected} isdir
]} {
2586 fileselect.yck
"isdirectory failed"
2589 if {[catch {glob $selected} globlist
]} {
2590 if {![file isdirectory
[file dirname
$selected]]} {
2591 fileselect.yck
"bad pathname"
2594 set globlist
$selected
2599 if {[llength $globlist] > 1} {
2600 set dir
[file dirname
$selected]
2601 set pat
[file tail
$selected]
2602 fileselect.getfiles
$dir $pat
2605 set selected
$globlist
2607 if {[file isdirectory
$selected]} {
2608 fileselect.getfiles
$selected $fileselect(pattern
)
2609 $fileselect(entry) delete
0 end
2616 set fileselect
(result
) $selected
2621 proc fileselect.getfiles
{ dir
{pat
*} {state normal
} } {
2623 $fileselect(msg
) configure
-text Listing...
2626 set currentDir
[pwd]
2628 if {[catch {set files
[lsort [glob -nocomplain $pat]]} err
]} {
2629 $fileselect(msg
) configure
-text $err
2630 $fileselect(list) delete
0 end
2636 # Normal case - show current directory
2637 $fileselect(direntry
) delete
0 end
2638 $fileselect(direntry
) insert
0 [pwd]/
2641 # Directory already OK (tab related)
2644 # Changing directory (tab related)
2645 fileselect.
cd $currentDir
2648 # Avoid listing huge directories upon startup.
2649 $fileselect(direntry
) delete
0 end
2650 $fileselect(direntry
) insert
0 [pwd]/
2651 if {[llength $files] > 32} {
2658 # build a reordered list of the files: directories are displayed first
2659 # and marked with a trailing "/"
2660 if {[string compare
$dir /]} {
2661 fileselect.putfiles
$files [expr {($pat == "*") ?
1 : 0}]
2663 fileselect.putfiles
$files
2668 proc fileselect.putfiles
{files
{dotdot
0} } {
2671 $fileselect(list) delete
0 end
2673 $fileselect(list) insert end
"../"
2676 if {[file isdirectory
$i]} {
2677 $fileselect(list) insert end
$i/
2679 $fileselect(list) insert end
$i
2684 proc FileExistsDialog
{ name
} {
2687 set fileExists
(ok
) 0
2689 message $w.msg
-aspect 1000
2690 pack $w.msg
-side top
-fill both
-padx 20 -pady 20
2691 $w.but.quit config
-text Cancel
-command {FileExistsCancel
}
2692 button $w.but.ok
-text OK
-command {FileExistsOK
}
2693 pack $w.but.ok
-side left
2694 bind $w.msg
<Return
> {FileExistsOK
}
2696 $w.msg config
-text "Warning: file exists
2698 OK to overwrite it?"
2700 set fileExists
(focus) [focus]
2703 tkwait variable fileExists
(ok
)
2706 return $fileExists(ok
)
2709 proc FileExistsCancel
{} {
2711 set fileExists
(ok
) 0
2714 proc FileExistsOK
{} {
2716 set fileExists
(ok
) 1
2719 proc fileselect.getfiledir
{ dir
{basedir
[pwd]} } {
2722 set path
[$fileselect(direntry
) get
]
2726 if {[string index
$path 0] == "~"} {
2730 set path
[$fileselect(entry) get
]
2732 if {[catch {set listFile
[glob -nocomplain $path*]}]} {
2735 foreach el
$listFile {
2737 if {[file isdirectory
$el]} {
2738 lappend returnList
[file tail
$el]
2740 } elseif
{![file isdirectory
$el]} {
2741 lappend returnList
[file tail
$el]
2748 proc fileselect.gethead
{ list } {
2751 for {set i
0} {[string length
[lindex $list 0]] > $i}\
2752 {incr i
; set returnHead
$returnHead$thisChar} {
2753 set thisChar
[string index
[lindex $list 0] $i]
2755 if {[string length
$el] < $i} {
2758 if {$thisChar != [string index
$el $i]} {
2766 # FIXME this function is a crock. Can write tilde expanding function
2767 # in terms of glob and quote_glob; do so.
2768 proc fileselect.expand.tilde
{ } {
2771 set entry [$fileselect(direntry
) get
]
2772 set dir
[string range
$entry 1 [string length
$entry]]
2780 ## look in /etc/passwd
2781 if {[file exists
/etc
/passwd
]} {
2782 if {[catch {set users
[exec cat
/etc
/passwd | sed s
/:.
*//]} err
]} {
2783 puts "Error\#1 $err"
2786 set list [split $users "\n"]
2788 if {[lsearch -exact $list "+"] != -1} {
2789 if {[catch {set users
[exec ypcat passwd | sed s
/:.
*//]} err
]} {
2790 puts "Error\#2 $err"
2793 set list [concat $list [split $users "\n"]]
2795 $fileselect(list) delete
0 end
2797 if {[string match
$dir* $el]} {
2798 lappend listmatch
$el
2799 $fileselect(list) insert end
$el
2802 set addings
[fileselect.gethead
$listmatch]
2803 if {$addings == ""} {
2806 $fileselect(direntry
) delete
0 end
2807 if {[llength $listmatch] == 1} {
2808 $fileselect(direntry
) insert
0 [file dirname ~
$addings/]
2809 fileselect.getfiles
[$fileselect(direntry
) get
]
2811 $fileselect(direntry
) insert
0 ~
$addings
2815 proc fileselect.tab.dircmd
{ } {
2818 set dir
[$fileselect(direntry
) get
]
2820 $fileselect(direntry
) delete
0 end
2821 $fileselect(direntry
) insert
0 [pwd]
2822 if {[string compare
[pwd] "/"]} {
2823 $fileselect(direntry
) insert end
/
2827 if {[catch {set tmp
[file isdirectory
[file dirname
$dir]]}]} {
2828 if {[string index
$dir 0] == "~"} {
2829 fileselect.expand.tilde
2836 set dirFile
[fileselect.getfiledir
1 $dir]
2837 if {![llength $dirFile]} {
2840 if {[llength $dirFile] == 1} {
2841 $fileselect(direntry
) delete
0 end
2842 $fileselect(direntry
) insert
0 [file dirname
$dir]
2843 if {[string compare
[file dirname
$dir] /]} {
2844 $fileselect(direntry
) insert end
/[lindex $dirFile 0]/
2846 $fileselect(direntry
) insert end
[lindex $dirFile 0]/
2848 fileselect.getfiles
[$fileselect(direntry
) get
] \
2849 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2852 set headFile
[fileselect.gethead
$dirFile]
2853 $fileselect(direntry
) delete
0 end
2854 $fileselect(direntry
) insert
0 [file dirname
$dir]
2855 if {[string compare
[file dirname
$dir] /]} {
2856 $fileselect(direntry
) insert end
/$headFile
2858 $fileselect(direntry
) insert end
$headFile
2860 if {$headFile == "" && [file isdirectory
$dir]} {
2861 fileselect.getfiles
$dir\
2862 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2864 fileselect.getfiles
[file dirname
$dir]\
2865 "[file tail [$fileselect(direntry) get]]*" newdir
2869 proc fileselect.tab.filecmd
{ } {
2872 set dir
[$fileselect(direntry
) get
]
2876 if {![file isdirectory
$dir]} {
2877 error "dir $dir doesn't exist"
2879 set listFile
[fileselect.getfiledir
0 $dir]
2881 if {![llength $listFile]} {
2884 if {[llength $listFile] == 1} {
2885 $fileselect(entry) delete
0 end
2886 $fileselect(entry) insert
0 [lindex $listFile 0]
2889 set headFile
[fileselect.gethead
$listFile]
2890 $fileselect(entry) delete
0 end
2891 $fileselect(entry) insert
0 $headFile
2892 fileselect.getfiles
$dir "[$fileselect(entry) get]$fileselect(pattern)" opt
2895 proc Exwin_Toplevel
{ path name
{class Dialog
} {dismiss yes
}} {
2897 if {[catch {wm state
$path} state
]} {
2898 set t
[Widget_Toplevel
$path $name $class]
2899 if {![info exists exwin
(toplevels
)]} {
2900 set exwin
(toplevels
) [option get . exwinPaths
{}]
2902 set ix
[lsearch $exwin(toplevels
) $t]
2904 lappend exwin
(toplevels
) $t
2906 if {$dismiss == "yes"} {
2907 set f
[Widget_Frame
$t but Menubar
{top fill
}]
2908 Widget_AddBut
$f quit
"Dismiss" [list Exwin_Dismiss
$path]
2912 if {$state != "normal"} {
2914 wm geometry
$path $exwin(geometry
,$path)
2915 # Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
2925 proc Exwin_Dismiss
{ path
{geo ok
} } {
2929 set exwin
(geometry
,$path) [wm geometry
$path]
2932 set exwin
(geometry
,$path) [string trimleft
[wm geometry
$path] 0123456789x
]
2935 catch {unset exwin
(geometry
,$path)}
2941 proc Widget_Toplevel
{ path name
{class Dialog
} {x
{}} {y
{}} } {
2942 set self
[toplevel $path -class $class]
2943 set usergeo
[option get
$path position Position
]
2944 if {$usergeo != {}} {
2945 if {[catch {wm geometry
$self $usergeo} err
]} {
2946 # Exmh_Debug Widget_Toplevel $self $usergeo => $err
2949 if {($x != {}) && ($y != {})} {
2950 # Exmh_Debug Event position $self +$x+$y
2951 wm geometry
$self +$x+$y
2954 wm title
$self $name
2959 proc Widget_Frame
{par child
{class GDB
} {where
{top expand fill
}} args
} {
2963 set self
$par.
$child
2965 eval {frame $self -class $class} $args
2966 pack append $par $self $where
2970 proc Widget_AddBut
{par but txt cmd
{where
{right padx
1}} } {
2971 # Create a Packed button. Return the button pathname
2972 set cmd2
[list button $par.
$but -text $txt -command $cmd]
2973 if {[catch $cmd2 t
]} {
2974 puts stderr
"Widget_AddBut (warning) $t"
2975 eval $cmd2 {-font fixed
}
2977 pack append $par $par.
$but $where
2981 proc Widget_CheckBut
{par but txt var
{where
{right padx
1}} } {
2982 # Create a check button. Return the button pathname
2983 set cmd
[list checkbutton $par.
$but -text $txt -variable $var]
2984 if {[catch $cmd t
]} {
2985 puts stderr
"Widget_CheckBut (warning) $t"
2986 eval $cmd {-font fixed
}
2988 pack append $par $par.
$but $where
2992 proc Widget_Label
{ frame {name
label} {where
{left fill
}} args
} {
2993 set cmd
[list label $frame.
$name ]
2994 if {[catch [concat $cmd $args] t
]} {
2995 puts stderr
"Widget_Label (warning) $t"
2996 eval $cmd $args {-font fixed
}
2998 pack append $frame $frame.
$name $where
3002 proc Widget_Entry
{ frame {name
entry} {where
{left fill
}} args
} {
3003 set cmd
[list entry $frame.
$name ]
3004 if {[catch [concat $cmd $args] t
]} {
3005 puts stderr
"Widget_Entry (warning) $t"
3006 eval $cmd $args {-font fixed
}
3008 pack append $frame $frame.
$name $where
3012 # End of fileselect.tcl.
3015 # Create a copyright window and center it on the screen. Arrange for
3016 # it to disappear when the user clicks it, or after a suitable period
3019 proc create_copyright_window
{} {
3021 message .c.m
-text [gdb_cmd
{show version
}] -aspect 500 -relief raised
3024 bind .c.m
<1> {destroy .c
}
3025 # "suitable period" currently means "15 seconds".
3027 if {[winfo exists .c
]} then
{
3036 # FIXME need to handle mono here. In Tk4 that is more complicated.
3037 set highlight
"-background red2 -borderwidth 2 -relief sunken"
3039 # Setup the initial windows
3040 create_source_window
3041 create_command_window
3043 # Make this last so user actually sees it.
3044 create_copyright_window
3048 if {[file exists ~
/.gdbtkinit
]} {