set line_numbers 1
set breakpoint_file(-1) {[garbage]}
set disassemble_with_source nosource
-set expr_update_list(0) 0
+set gdb_prompt "(gdb) "
+# Hint: The following can be toggled from a tclsh window after
+# using the gdbtk "tk tclsh" command to open the window.
set debug_interface 0
#option add *Foreground Black
#
# Center a window on the screen.
#
-proc center_window toplevel {
+proc center_window {toplevel} {
# Withdraw and update, to ensure geometry computations are finished.
wm withdraw $toplevel
update idletasks
${action}_breakpoint $bpnum $file $line $pc
}
+#
+# GDB Callback:
+#
+# gdbtk_tcl_readline_begin (message) - Notify Tk to open an interaction
+# window and start gathering user input
+#
+# Description:
+#
+# GDB calls this to notify TK that it needs to open an interaction
+# window, displaying the given message, and be prepared to accept
+# calls to gdbtk_tcl_readline to gather user input.
+
+proc gdbtk_tcl_readline_begin {message} {
+ global readline_text
+
+ # If another readline window already exists, just bring it to the front.
+ if {[winfo exists .rl]} {raise .rl ; return}
+
+ # Create top level frame with scrollbar and text widget.
+ toplevel .rl
+ wm title .rl "Interaction Window"
+ wm iconname .rl "Input"
+ message .rl.msg -text $message -aspect 7500 -justify left
+ text .rl.text -width 80 -height 20 -setgrid true -cursor hand2 \
+ -yscrollcommand {.rl.scroll set}
+ scrollbar .rl.scroll -command {.rl.text yview}
+ pack .rl.msg -side top -fill x
+ pack .rl.scroll -side right -fill y
+ pack .rl.text -side left -fill both -expand true
+
+ # When the user presses return, get the text from the command start mark to the
+ # current insert point, stash it in the readline text variable, and update the
+ # command start mark to the current insert point
+ bind .rl.text <Return> {
+ set readline_text [.rl.text get cmdstart {end - 1 char}]
+ .rl.text mark set cmdstart insert
+ }
+ bind .rl.text <BackSpace> {
+ if [%W compare insert > cmdstart] {
+ %W delete {insert - 1 char} insert
+ } else {
+ bell
+ }
+ break
+ }
+ bind .rl.text <Any-Key> {
+ if [%W compare insert < cmdstart] {
+ %W mark set insert end
+ }
+ }
+ bind .rl.text <Control-u> {
+ %W delete cmdstart "insert lineend"
+ %W see insert
+ }
+ bindtags .rl.text {.rl.text Text all}
+}
+
+#
+# GDB Callback:
+#
+# gdbtk_tcl_readline (prompt) - Get one user input line
+#
+# Description:
+#
+# GDB calls this to get one line of input from the user interaction
+# window, using "prompt" as the command line prompt.
+
+proc gdbtk_tcl_readline {prompt} {
+ global readline_text
+
+ .rl.text insert end $prompt
+ .rl.text mark set cmdstart insert
+ .rl.text mark gravity cmdstart left
+ .rl.text see insert
+
+ # Make this window the current one for input.
+ focus .rl.text
+ grab .rl
+ tkwait variable readline_text
+ grab release .rl
+ return $readline_text
+}
+
+#
+# GDB Callback:
+#
+# gdbtk_tcl_readline_end - Terminate a user interaction
+#
+# Description:
+#
+# GDB calls this when it is done getting interactive user input.
+# Destroy the interaction window.
+
+proc gdbtk_tcl_readline_end {} {
+ if {[winfo exists .rl]} { destroy .rl }
+}
+
proc create_breakpoints_window {} {
global bpframe_lasty
# Create a frame for bpnum in the .breakpoints canvas
-proc add_breakpoint_frame bpnum {
+proc add_breakpoint_frame {bpnum} {
global bpframe_lasty
global enabled
global disposition
# Delete a breakpoint frame
-proc delete_breakpoint_frame bpnum {
+proc delete_breakpoint_frame {bpnum} {
global bpframe_lasty
if {![winfo exists .breakpoints]} return
# Create the expression display window.
#
-set expr_num 0
-set delete_expr_num 0
-
# Set delete_expr_num, and set -state of Delete button.
proc expr_update_button {num} {
global delete_expr_num
proc delete_expr {} {
global delete_expr_num
+ global expr_update_list
+
if {$delete_expr_num > 0} then {
set e .expr.exprs
set f e${delete_expr_num}
destroy $e.updates.$f $e.expressions.$f $e.values.$f
-
- # FIXME should we unset an element of expr_update_list here?
+ unset expr_update_list($delete_expr_num)
}
}
}
proc create_expr_window {} {
+ global expr_num
+ global delete_expr_num
+ global expr_update_list
if {[winfo exists .expr]} {raise .expr ; return}
+ # All the state about individual expressions is stored in the
+ # expression window widgets, so when it is deleted, the
+ # previous values of the expression global variables become
+ # invalid. Reset to a known initial state.
+ set expr_num 0
+ set delete_expr_num 0
+ catch {unset expr_update_list}
+ set expr_update_list(0) 0
+
toplevel .expr
wm title .expr "GDB Expressions"
wm iconname .expr "Expressions"
#
proc create_registers_window {} {
- global reg_format
+ global reg_format_natural
+ global reg_format_decimal
+ global reg_format_hex
+ global reg_format_octal
+ global reg_format_raw
+ global reg_format_binary
+ global reg_format_unsigned
- if {[winfo exists .reg]} {raise .reg ; return}
+ # If we already have a register window, just use that one.
-# Create an initial register display list consisting of all registers
+ if {[winfo exists .reg]} {raise .reg ; return}
- if {![info exists reg_format]} {
- global reg_display_list
- global changed_reg_list
- global regena
+ # Create an initial register display list consisting of all registers
- set reg_format {}
- set num_regs [llength [gdb_regnames]]
- for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
- set regena($regnum) 1
- }
- recompute_reg_display_list $num_regs
- set changed_reg_list $reg_display_list
- }
+ init_reg_info
- build_framework .reg Registers
+ build_framework .reg Registers
-# First, delete all the old menu entries
+ # First, delete all the old menu entries
+
+ .reg.menubar.view.menu delete 0 last
+
+ # Natural menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_natural(label) \
+ -variable reg_format_natural(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
- .reg.menubar.view.menu delete 0 last
+ # Decimal menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_decimal(label) \
+ -variable reg_format_decimal(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
-# Hex menu item
- .reg.menubar.view.menu add radiobutton -label Hex \
- -command {set reg_format x ; update_registers all}
+ # Hex menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_hex(label) \
+ -variable reg_format_hex(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
-# Decimal menu item
- .reg.menubar.view.menu add radiobutton -label Decimal \
- -command {set reg_format d ; update_registers all}
+ # Octal menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_octal(label) \
+ -variable reg_format_octal(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
-# Octal menu item
- .reg.menubar.view.menu add radiobutton -label Octal \
- -command {set reg_format o ; update_registers all}
+ # Binary menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_binary(label) \
+ -variable reg_format_binary(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
-# Natural menu item
- .reg.menubar.view.menu add radiobutton -label Natural \
- -command {set reg_format {} ; update_registers all}
+ # Unsigned menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_unsigned(label) \
+ -variable reg_format_unsigned(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
-# Config menu item
- .reg.menubar.view.menu add separator
+ # Raw menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_raw(label) \
+ -variable reg_format_raw(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
- .reg.menubar.view.menu add command -label Config -command {
- reg_config_menu }
+ # Config menu item
+ .reg.menubar.view.menu add separator
- destroy .reg.label
+ .reg.menubar.view.menu add command -label Config \
+ -command { reg_config_menu }
-# Install the reg names
+ destroy .reg.label
- populate_reg_window
- update_registers all
+ # Install the reg names
+
+ populate_reg_window
+ update_registers all
+}
+
+proc init_reg_info {} {
+ global reg_format_natural
+ global reg_format_decimal
+ global reg_format_hex
+ global reg_format_octal
+ global reg_format_raw
+ global reg_format_binary
+ global reg_format_unsigned
+ global long_size
+ global double_size
+
+ if {![info exists reg_format_hex]} {
+ global reg_display_list
+ global changed_reg_list
+ global regena
+
+ set long_size [lindex [gdb_cmd {p sizeof(long)}] 2]
+ set double_size [lindex [gdb_cmd {p sizeof(double)}] 2]
+
+ # The natural format may print floats or doubles as floating point,
+ # which typically takes more room that printing ints on the same
+ # machine. We assume that if longs are 8 bytes that this is
+ # probably a 64 bit machine. (FIXME)
+ set reg_format_natural(label) Natural
+ set reg_format_natural(enable) on
+ set reg_format_natural(format) {}
+ if {$long_size == 8} then {
+ set reg_format_natural(width) 25
+ } else {
+ set reg_format_natural(width) 16
+ }
+
+ set reg_format_decimal(label) Decimal
+ set reg_format_decimal(enable) off
+ set reg_format_decimal(format) d
+ if {$long_size == 8} then {
+ set reg_format_decimal(width) 21
+ } else {
+ set reg_format_decimal(width) 12
+ }
+
+ set reg_format_hex(label) Hex
+ set reg_format_hex(enable) off
+ set reg_format_hex(format) x
+ set reg_format_hex(width) [expr $long_size * 2 + 3]
+
+ set reg_format_octal(label) Octal
+ set reg_format_octal(enable) off
+ set reg_format_octal(format) o
+ set reg_format_octal(width) [expr $long_size * 8 / 3 + 3]
+
+ set reg_format_raw(label) Raw
+ set reg_format_raw(enable) off
+ set reg_format_raw(format) r
+ set reg_format_raw(width) [expr $double_size * 2 + 3]
+
+ set reg_format_binary(label) Binary
+ set reg_format_binary(enable) off
+ set reg_format_binary(format) t
+ set reg_format_binary(width) [expr $long_size * 8 + 1]
+
+ set reg_format_unsigned(label) Unsigned
+ set reg_format_unsigned(enable) off
+ set reg_format_unsigned(format) u
+ if {$long_size == 8} then {
+ set reg_format_unsigned(width) 21
+ } else {
+ set reg_format_unsigned(width) 11
+ }
+
+ set num_regs [llength [gdb_regnames]]
+ for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
+ set regena($regnum) 1
+ }
+ recompute_reg_display_list $num_regs
+ #set changed_reg_list $reg_display_list
+ set changed_reg_list {}
+ }
}
# Convert regena into a list of the enabled $regnums
global regena
catch {unset reg_display_list}
+ set reg_display_list {}
- set line 1
+ set line 2
for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
if {[set regena($regnum)] != 0} {
# reg_display_list.
proc populate_reg_window {} {
- global max_regname_width
- global reg_display_list
-
- .reg.text configure -state normal
-
- .reg.text delete 0.0 end
-
+ global reg_format_natural
+ global reg_format_decimal
+ global reg_format_hex
+ global reg_format_octal
+ global reg_format_raw
+ global reg_format_binary
+ global reg_format_unsigned
+ global max_regname_width
+ global reg_display_list
+
+ set win .reg.text
+ $win configure -state normal
+
+ # Clear the entire widget and insert a blank line at the top where
+ # the column labels will appear.
+ $win delete 0.0 end
+ $win insert end "\n"
+
+ if {[llength $reg_display_list] > 0} {
set regnames [eval gdb_regnames $reg_display_list]
+ } else {
+ set regnames {}
+ }
-# Figure out the longest register name
-
- set max_regname_width 0
+ # Figure out the longest register name
- foreach reg $regnames {
- set len [string length $reg]
- if {$len > $max_regname_width} {set max_regname_width $len}
- }
+ set max_regname_width 0
- set width [expr $max_regname_width + 15]
+ foreach reg $regnames {
+ set len [string length $reg]
+ if {$len > $max_regname_width} {set max_regname_width $len}
+ }
- set height [llength $regnames]
+ set width [expr $max_regname_width + 15]
- if {$height > 60} {set height 60}
+ set height [expr [llength $regnames] + 1]
- .reg.text configure -height $height -width $width
+ if {$height > 60} {set height 60}
- foreach reg $regnames {
- .reg.text insert end [format "%-*s \n" $max_regname_width ${reg}]
- }
+ $win configure -height $height -width $width
+ foreach reg $regnames {
+ $win insert end [format "%-*s\n" $width ${reg}]
+ }
- .reg.text yview 0
- .reg.text configure -state disabled
+ #Delete the blank line left at end by last insertion.
+ if {[llength $regnames] > 0} {
+ $win delete {end - 1 char} end
+ }
+ $win yview 0
+ $win configure -state disabled
}
#
#
# Description:
#
-# This procedure updates the registers window.
+# This procedure updates the registers window according to the value of
+# the "which" arg.
#
proc update_registers {which} {
- global max_regname_width
- global reg_format
- global reg_display_list
- global changed_reg_list
- global highlight
- global regmap
-
- set margin [expr $max_regname_width + 1]
- set win .reg.text
- set winwidth [lindex [$win configure -width] 4]
- set valwidth [expr $winwidth - $margin]
-
- $win configure -state normal
-
- if {$which == "all"} {
- set lineindex 1
- foreach regnum $reg_display_list {
- set regval [gdb_fetch_registers $reg_format $regnum]
- set regval [format "%-*s" $valwidth $regval]
- $win delete $lineindex.$margin "$lineindex.0 lineend"
- $win insert $lineindex.$margin $regval
- incr lineindex
- }
- $win configure -state disabled
- return
+ global max_regname_width
+ global reg_format_natural
+ global reg_format_decimal
+ global reg_format_hex
+ global reg_format_octal
+ global reg_format_binary
+ global reg_format_unsigned
+ global reg_format_raw
+ global reg_display_list
+ global changed_reg_list
+ global highlight
+ global regmap
+
+ # margin is the column where we start printing values
+ set margin [expr $max_regname_width + 1]
+ set win .reg.text
+ $win configure -state normal
+
+ if {$which == "all" || $which == "redraw"} {
+ set display_list $reg_display_list
+ $win delete 1.0 1.end
+ $win insert 1.0 [format "%*s" $max_regname_width " "]
+ foreach format {natural decimal unsigned hex octal raw binary } {
+ set field (enable)
+ set var reg_format_$format$field
+ if {[set $var] == "on"} {
+ set field (label)
+ set var reg_format_$format$field
+ set label [set $var]
+ set field (width)
+ set var reg_format_$format$field
+ set var [format "%*s" [set $var] $label]
+ $win insert 1.end $var
+ }
}
-
-# Unhighlight the old values
-
+ } else {
+ # Unhighlight the old values
foreach regnum $changed_reg_list {
- $win tag delete $win.$regnum
+ $win tag delete $win.$regnum
}
-
-# Now, highlight the changed values of the interesting registers
-
set changed_reg_list [eval gdb_changed_register_list $reg_display_list]
-
- set lineindex 1
+ set display_list $changed_reg_list
+ }
+ foreach regnum $display_list {
+ set lineindex $regmap($regnum)
+ $win delete $lineindex.$margin "$lineindex.0 lineend"
+ foreach format {natural decimal unsigned hex octal raw binary } {
+ set field (enable)
+ set var reg_format_$format$field
+ if {[set $var] == "on"} {
+ set field (format)
+ set var reg_format_$format$field
+ set regval [gdb_fetch_registers [set $var] $regnum]
+ set field (width)
+ set var reg_format_$format$field
+ set regval [format "%*s" [set $var] $regval]
+ $win insert $lineindex.end $regval
+ }
+ }
+ }
+ # Now, highlight the changed values of the interesting registers
+ if {$which != "all"} {
foreach regnum $changed_reg_list {
- set regval [gdb_fetch_registers $reg_format $regnum]
- set regval [format "%-*s" $valwidth $regval]
-
- set lineindex $regmap($regnum)
- $win delete $lineindex.$margin "$lineindex.0 lineend"
- $win insert $lineindex.$margin $regval
- $win tag add $win.$regnum $lineindex.0 "$lineindex.0 lineend"
- eval $win tag configure $win.$regnum $highlight
+ set lineindex $regmap($regnum)
+ $win tag add $win.$regnum $lineindex.0 "$lineindex.0 lineend"
+ eval $win tag configure $win.$regnum $highlight
}
-
- $win configure -state disabled
+ }
+ set winwidth $margin
+ foreach format {natural decimal unsigned hex octal raw binary} {
+ set field (enable)
+ set var reg_format_$format$field
+ if {[set $var] == "on"} {
+ set field (width)
+ set var reg_format_$format$field
+ set winwidth [expr $winwidth + [set $var]]
+ }
+ }
+ $win configure -width $winwidth
+ $win configure -state disabled
}
#
button .files_window.close -text Close -command {destroy .files_window}
.files_window.list configure -selectmode single
- # Get the file list from GDB, sort it, and format it as one entry per line.
- set lastSeen {}; # Value that won't appear in
- # list.
- set fileList {}
- foreach file [lsort [gdb_listfiles]] {
- if {$file != $lastSeen} then {
- lappend fileList $file
- set lastSeen $file
- }
- }
- set filelist [join [lsort [gdb_listfiles]] "\n"]
-
- # Insert the file list into the widget
-
- eval .files_window.list insert 0 $filelist
+ # Get the file list from GDB, sort it, and insert into the widget.
+ eval .files_window.list insert 0 [lsort [gdb_listfiles]]
pack .files_window.close -side bottom -fill x -expand no -anchor s
pack .files_window.scroll -side right -fill both
pack .files_window.list -side left -fill both -expand yes
- bind .files_window.list <Any-ButtonRelease-1> {
+ bind .files_window.list <ButtonRelease-1> {
set file [%W get [%W curselection]]
gdb_cmd "list $file:1,0"
update_listing [gdb_loc $file:1]
destroy .files_window
}
+ # We must execute the listbox binding first, because it
+ # references the widget that will be destroyed by the widget
+ # binding for Button-Release-1. Otherwise we try to use
+ # .files_window.list after the .files_window is destroyed.
+ bind_widget_after_class .files_window.list
}
button .files -text Files -command files_command
proc apply_filespec {label default command} {
- set filename [FSBox $label $default]
+ set filename [tk_getOpenFile -title $label -initialfile $default]
if {$filename != ""} {
if {[catch {gdb_cmd "$command $filename"} retval]} {
tk_dialog .filespec_error "gdb : $label error" \
proc create_command_window {} {
global command_line
global saw_tab
+ global gdb_prompt
set saw_tab 0
if {[winfo exists .cmd]} {raise .cmd ; return}
set bsBinding [bind Text <BackSpace>]
bind .cmd.text <Delete> "delete_char %W ; $bsBinding; break"
bind .cmd.text <BackSpace> {
- if {([%W get -state] == "disabled")} { break }
+ if {([%W cget -state] == "disabled")} { break }
delete_char %W
}
bind .cmd.text <Control-u> {
# %W insert end $result
set command_line {}
# update_ptr
- %W insert end "(gdb) "
+ %W insert end "$gdb_prompt"
%W see end
break
}
if {[regexp ".* " $command_line prefix]} {
regsub -all $prefix $choices {} choices
}
- %W insert end "\n[join $choices { }]\n(gdb) $command_line"
+ %W insert end "\n[join $choices { }]\n$gdb_prompt$command_line"
%W see end
}
break
}
}
+# Trim one character off the command line. The argument is ignored.
+
proc delete_char {win} {
global command_line
set tmp [expr [string length $command_line] - 2]
set command_line [string range $command_line 0 $tmp]
}
+# FIXME: This should actually check that the first characters of the current
+# line match the gdb prompt, since the user can move the insertion point
+# anywhere. It should also check that the insertion point is in the last
+# line of the text widget.
+
proc delete_line {win} {
- global command_line
+ global command_line
+ global gdb_prompt
- $win delete {end linestart + 6 chars} end
- $win see insert
- set command_line {}
+ set tmp [string length $gdb_prompt]
+ $win delete "insert linestart + $tmp chars" "insert lineend"
+ $win see insert
+ set command_line {}
}
#
-# fileselect.tcl --
-# simple file selector.
-#
-# Mario Jorge Silva msilva@cs.Berkeley.EDU
-# University of California Berkeley Ph: +1(510)642-8248
-# Computer Science Division, 571 Evans Hall Fax: +1(510)642-5775
-# Berkeley CA 94720
-#
-#
-# Copyright 1993 Regents of the University of California
-# Permission to use, copy, modify, and distribute this
-# software and its documentation for any purpose and without
-# fee is hereby granted, provided that this copyright
-# notice appears in all copies. The University of California
-# makes no representations about the suitability of this
-# software for any purpose. It is provided "as is" without
-# express or implied warranty.
+# Create a copyright window and center it on the screen. Arrange for
+# it to disappear when the user clicks it, or after a suitable period
+# of time.
#
+proc create_copyright_window {} {
+ toplevel .c
+ message .c.m -text [gdb_cmd {show version}] -aspect 500 -relief raised
+ pack .c.m
-
-# names starting with "fileselect" are reserved by this module
-# no other names used.
-# Hack - FSBox is defined instead of fileselect for backwards compatibility
-
-
-# this is the proc that creates the file selector box
-# purpose - comment string
-# defaultName - initial value for name
-# cmd - command to eval upon OK
-# errorHandler - command to eval upon Cancel
-# If neither cmd or errorHandler are specified, the return value
-# of the FSBox procedure is the selected file name.
-
-proc FSBox {{purpose "Select file:"} {defaultName ""} {cmd ""} {errorHandler
-""}} {
- global fileselect
- set w .fileSelect
- if {[Exwin_Toplevel $w "Select File" FileSelect]} {
- # path independent names for the widgets
-
- set fileselect(list) $w.file.sframe.list
- set fileselect(scroll) $w.file.sframe.scroll
- set fileselect(direntry) $w.file.f1.direntry
- set fileselect(entry) $w.file.f2.entry
- set fileselect(ok) $w.but.ok
- set fileselect(cancel) $w.but.cancel
- set fileselect(msg) $w.label
-
- set fileselect(result) "" ;# value to return if no callback procedures
-
- # widgets
- Widget_Label $w label {top fillx pady 10 padx 20} -anchor w -width 24
- Widget_Frame $w file Dialog {left expand fill} -bd 10
-
- Widget_Frame $w.file f1 Exmh {top fillx}
- Widget_Label $w.file.f1 label {left} -text "Dir"
- Widget_Entry $w.file.f1 direntry {right fillx expand} -width 30
-
- Widget_Frame $w.file sframe
-
- scrollbar $w.file.sframe.yscroll -relief sunken \
- -command [list $w.file.sframe.list yview]
- listbox $w.file.sframe.list -relief sunken \
- -yscroll [list $w.file.sframe.yscroll set] -setgrid 1
- pack append $w.file.sframe \
- $w.file.sframe.yscroll {right filly} \
- $w.file.sframe.list {left expand fill}
-
- Widget_Frame $w.file f2 Exmh {top fillx}
- Widget_Label $w.file.f2 label {left} -text Name
- Widget_Entry $w.file.f2 entry {right fillx expand}
-
- # buttons
- $w.but.quit configure -text Cancel \
- -command [list fileselect.cancel.cmd $w]
-
- Widget_AddBut $w.but ok OK \
- [list fileselect.ok.cmd $w $cmd $errorHandler] {left padx 1}
-
- Widget_AddBut $w.but list List \
- [list fileselect.list.cmd $w] {left padx 1}
- Widget_CheckBut $w.but listall "List all" fileselect(pattern)
- $w.but.listall configure -onvalue "{*,.*}" -offvalue "*" \
- -command {fileselect.list.cmd $fileselect(direntry)}
- $w.but.listall deselect
-
- # Set up bindings for the browser.
- foreach ww [list $w $fileselect(entry)] {
- bind $ww <Return> [list $fileselect(ok) invoke]
- bind $ww <Control-c> [list $fileselect(cancel) invoke]
- }
- bind $fileselect(direntry) <Return> [list fileselect.list.cmd %W]
- bind $fileselect(direntry) <Tab> [list fileselect.tab.dircmd]
- bind $fileselect(entry) <Tab> [list fileselect.tab.filecmd]
-
- $fileselect(list) configure -selectmode single
-
- bind $fileselect(list) <Button-1> {
- # puts stderr "button 1 release"
- $fileselect(entry) delete 0 end
- $fileselect(entry) insert 0 [%W get [%W nearest %y]]
- }
-
- bind $fileselect(list) <Key> {
- $fileselect(entry) delete 0 end
- $fileselect(entry) insert 0 [%W get [%W nearest %y]]
- }
-
- bind $fileselect(list) <Double-ButtonPress-1> {
- # puts stderr "double button 1"
- $fileselect(entry) delete 0 end
- $fileselect(entry) insert 0 [%W get [%W nearest %y]]
- $fileselect(ok) invoke
- }
-
- bind $fileselect(list) <Return> {
- $fileselect(entry) delete 0 end
- $fileselect(entry) insert 0 [%W get [%W nearest %y]]
- $fileselect(ok) invoke
- }
- }
- set fileselect(text) $purpose
- $fileselect(msg) configure -text $purpose
- $fileselect(entry) delete 0 end
- $fileselect(entry) insert 0 [file tail $defaultName]
-
- if {[info exists fileselect(lastDir)] && ![string length $defaultName]} {
- set dir $fileselect(lastDir)
- } else {
- set dir [file dirname $defaultName]
- }
- set fileselect(pwd) [pwd]
- fileselect.cd $dir
- $fileselect(direntry) delete 0 end
- $fileselect(direntry) insert 0 [pwd]/
-
- $fileselect(list) delete 0 end
- $fileselect(list) insert 0 "Big directory:"
- $fileselect(list) insert 1 $dir
- $fileselect(list) insert 2 "Press Return for Listing"
-
- fileselect.list.cmd $fileselect(direntry) startup
-
- # set kbd focus to entry widget
-
-# Exwin_ToplevelFocus $w $fileselect(entry)
-
- # Wait for button hits if no callbacks are defined
-
- if {"$cmd" == "" && "$errorHandler" == ""} {
- # wait for the box to be destroyed
- update idletask
- grab $w
- tkwait variable fileselect(result)
- grab release $w
-
- set path $fileselect(result)
- set fileselect(lastDir) [pwd]
- fileselect.cd $fileselect(pwd)
- return [string trimright [string trim $path] /]
- }
- fileselect.cd $fileselect(pwd)
- return ""
-}
-
-proc fileselect.cd { dir } {
- global fileselect
- if {[catch {cd $dir} err]} {
- fileselect.yck $dir
- cd
+ bind .c.m <1> {destroy .c}
+ bind .c <Leave> {destroy .c}
+ # "suitable period" currently means "30 seconds".
+ after 30000 {
+ if {[winfo exists .c]} then {
+ destroy .c
}
-}
-# auxiliary button procedures
-
-proc fileselect.yck { {tag {}} } {
- global fileselect
- $fileselect(msg) configure -text "Yck! $tag"
-}
-
-proc fileselect.ok {} {
- global fileselect
- $fileselect(msg) configure -text $fileselect(text)
-}
+ }
-proc fileselect.cancel.cmd {w} {
- global fileselect
- set fileselect(result) {}
- destroy $w
+ wm transient .c .
+ center_window .c
}
-proc fileselect.list.cmd {w {state normal}} {
- global fileselect
- set seldir [$fileselect(direntry) get]
- if {[catch {glob $seldir} dir]} {
- fileselect.yck "glob failed"
- return
- }
- if {[llength $dir] > 1} {
- set dir [file dirname $seldir]
- set pat [file tail $seldir]
- } else {
- set pat $fileselect(pattern)
- }
- fileselect.ok
- update idletasks
- if {[file isdirectory $dir]} {
- fileselect.getfiles $dir $pat $state
- focus $fileselect(entry)
- } else {
- fileselect.yck "not a dir"
- }
-}
+# Begin support primarily for debugging the tcl/tk portion of gdbtk. You can
+# start gdbtk, and then issue the command "tk tclsh" and a window will pop up
+# giving you direct access to the tcl interpreter. With this, it is very easy
+# to examine the values of global variables, directly invoke routines that are
+# part of the gdbtk interface, replace existing proc's with new ones, etc.
+# This code was inspired from example 11-3 in Brent Welch's "Practical
+# Programming in Tcl and Tk"
-proc fileselect.ok.cmd {w cmd errorHandler} {
- global fileselect
- set selname [$fileselect(entry) get]
- set seldir [$fileselect(direntry) get]
+set tcl_prompt "tcl> "
- if {[string match /* $selname]} {
- set selected $selname
- } else {
- if {[string match ~* $selname]} {
- set selected $selname
- } else {
- set selected $seldir/$selname
- }
- }
+# Get the current command that user has typed, from cmdstart to end of text
+# widget. Evaluate it, insert result back into text widget, issue a new
+# prompt, update text widget and update command start mark.
- # some nasty file names may cause "file isdirectory" to return an error
- if {[catch {file isdirectory $selected} isdir]} {
- fileselect.yck "isdirectory failed"
- return
- }
- if {[catch {glob $selected} globlist]} {
- if {![file isdirectory [file dirname $selected]]} {
- fileselect.yck "bad pathname"
- return
- }
- set globlist $selected
- }
- fileselect.ok
- update idletasks
+proc evaluate_tcl_command { twidget } {
+ global tcl_prompt
- if {[llength $globlist] > 1} {
- set dir [file dirname $selected]
- set pat [file tail $selected]
- fileselect.getfiles $dir $pat
- return
- } else {
- set selected $globlist
- }
- if {[file isdirectory $selected]} {
- fileselect.getfiles $selected $fileselect(pattern)
- $fileselect(entry) delete 0 end
+ set command [$twidget get cmdstart end]
+ if [info complete $command] {
+ set err [catch {uplevel #0 $command} result]
+ $twidget insert insert \n$result\n
+ $twidget insert insert $tcl_prompt
+ $twidget see insert
+ $twidget mark set cmdstart insert
return
}
-
- if {$cmd != {}} {
- $cmd $selected
- } else {
- set fileselect(result) $selected
- }
- destroy $w
}
-proc fileselect.getfiles { dir {pat *} {state normal} } {
- global fileselect
- $fileselect(msg) configure -text Listing...
- update idletasks
+# Create the evaluation window and set up the keybindings to evaluate the
+# last single line entered by the user. FIXME: allow multiple lines?
- set currentDir [pwd]
- fileselect.cd $dir
- if {[catch {set files [lsort [glob -nocomplain $pat]]} err]} {
- $fileselect(msg) configure -text $err
- $fileselect(list) delete 0 end
- update idletasks
- return
- }
- switch -- $state {
- normal {
- # Normal case - show current directory
- $fileselect(direntry) delete 0 end
- $fileselect(direntry) insert 0 [pwd]/
- }
- opt {
- # Directory already OK (tab related)
- }
- newdir {
- # Changing directory (tab related)
- fileselect.cd $currentDir
- }
- startup {
- # Avoid listing huge directories upon startup.
- $fileselect(direntry) delete 0 end
- $fileselect(direntry) insert 0 [pwd]/
- if {[llength $files] > 32} {
- fileselect.ok
- return
- }
- }
- }
+proc tclsh {} {
+ global tcl_prompt
- # build a reordered list of the files: directories are displayed first
- # and marked with a trailing "/"
- if {[string compare $dir /]} {
- fileselect.putfiles $files [expr {($pat == "*") ? 1 : 0}]
- } else {
- fileselect.putfiles $files
- }
- fileselect.ok
-}
+ # If another evaluation window already exists, just bring it to the front.
+ if {[winfo exists .eval]} {raise .eval ; return}
-proc fileselect.putfiles {files {dotdot 0} } {
- global fileselect
+ # Create top level frame with scrollbar and text widget.
+ toplevel .eval
+ wm title .eval "Tcl Evaluation"
+ wm iconname .eval "Tcl"
+ text .eval.text -width 80 -height 20 -setgrid true -cursor hand2 \
+ -yscrollcommand {.eval.scroll set}
+ scrollbar .eval.scroll -command {.eval.text yview}
+ pack .eval.scroll -side right -fill y
+ pack .eval.text -side left -fill both -expand true
- $fileselect(list) delete 0 end
- if {$dotdot} {
- $fileselect(list) insert end "../"
- }
- foreach i $files {
- if {[file isdirectory $i]} {
- $fileselect(list) insert end $i/
- } else {
- $fileselect(list) insert end $i
- }
- }
-}
+ # Insert the tcl_prompt and initialize the cmdstart mark
+ .eval.text insert insert $tcl_prompt
+ .eval.text mark set cmdstart insert
+ .eval.text mark gravity cmdstart left
-proc FileExistsDialog { name } {
- set w .fileExists
- global fileExists
- set fileExists(ok) 0
- {
- message $w.msg -aspect 1000
- pack $w.msg -side top -fill both -padx 20 -pady 20
- $w.but.quit config -text Cancel -command {FileExistsCancel}
- button $w.but.ok -text OK -command {FileExistsOK}
- pack $w.but.ok -side left
- bind $w.msg <Return> {FileExistsOK}
- }
- $w.msg config -text "Warning: file exists
-$name
-OK to overwrite it?"
-
- set fileExists(focus) [focus]
- focus $w.msg
- grab $w
- tkwait variable fileExists(ok)
- grab release $w
- destroy $w
- return $fileExists(ok)
-}
+ # Make this window the current one for input.
+ focus .eval.text
-proc FileExistsCancel {} {
- global fileExists
- set fileExists(ok) 0
-}
-
-proc FileExistsOK {} {
- global fileExists
- set fileExists(ok) 1
-}
-
-proc fileselect.getfiledir { dir {basedir [pwd]} } {
- global fileselect
-
- set path [$fileselect(direntry) get]
- set returnList {}
-
- if {$dir != 0} {
- if {[string index $path 0] == "~"} {
- set path $path/
- }
- } else {
- set path [$fileselect(entry) get]
- }
- if {[catch {set listFile [glob -nocomplain $path*]}]} {
- return $returnList
- }
- foreach el $listFile {
- if {$dir != 0} {
- if {[file isdirectory $el]} {
- lappend returnList [file tail $el]
- }
- } elseif {![file isdirectory $el]} {
- lappend returnList [file tail $el]
- }
- }
-
- return $returnList
-}
-
-proc fileselect.gethead { list } {
- set returnHead ""
-
- for {set i 0} {[string length [lindex $list 0]] > $i}\
- {incr i; set returnHead $returnHead$thisChar} {
- set thisChar [string index [lindex $list 0] $i]
- foreach el $list {
- if {[string length $el] < $i} {
- return $returnHead
- }
- if {$thisChar != [string index $el $i]} {
- return $returnHead
- }
- }
- }
- return $returnHead
-}
-
-# FIXME this function is a crock. Can write tilde expanding function
-# in terms of glob and quote_glob; do so.
-proc fileselect.expand.tilde { } {
- global fileselect
-
- set entry [$fileselect(direntry) get]
- set dir [string range $entry 1 [string length $entry]]
-
- if {$dir == ""} {
- return
- }
-
- set listmatch {}
-
- ## look in /etc/passwd
- if {[file exists /etc/passwd]} {
- if {[catch {set users [exec cat /etc/passwd | sed s/:.*//]} err]} {
- puts "Error\#1 $err"
- return
- }
- set list [split $users "\n"]
- }
- if {[lsearch -exact $list "+"] != -1} {
- if {[catch {set users [exec ypcat passwd | sed s/:.*//]} err]} {
- puts "Error\#2 $err"
- return
- }
- set list [concat $list [split $users "\n"]]
- }
- $fileselect(list) delete 0 end
- foreach el $list {
- if {[string match $dir* $el]} {
- lappend listmatch $el
- $fileselect(list) insert end $el
- }
- }
- set addings [fileselect.gethead $listmatch]
- if {$addings == ""} {
- return
- }
- $fileselect(direntry) delete 0 end
- if {[llength $listmatch] == 1} {
- $fileselect(direntry) insert 0 [file dirname ~$addings/]
- fileselect.getfiles [$fileselect(direntry) get]
- } else {
- $fileselect(direntry) insert 0 ~$addings
- }
-}
-
-proc fileselect.tab.dircmd { } {
- global fileselect
-
- set dir [$fileselect(direntry) get]
- if {$dir == ""} {
- $fileselect(direntry) delete 0 end
- $fileselect(direntry) insert 0 [pwd]
- if {[string compare [pwd] "/"]} {
- $fileselect(direntry) insert end /
- }
- return
- }
- if {[catch {set tmp [file isdirectory [file dirname $dir]]}]} {
- if {[string index $dir 0] == "~"} {
- fileselect.expand.tilde
- }
- return
- }
- if {!$tmp} {
- return
- }
- set dirFile [fileselect.getfiledir 1 $dir]
- if {![llength $dirFile]} {
- return
- }
- if {[llength $dirFile] == 1} {
- $fileselect(direntry) delete 0 end
- $fileselect(direntry) insert 0 [file dirname $dir]
- if {[string compare [file dirname $dir] /]} {
- $fileselect(direntry) insert end /[lindex $dirFile 0]/
+ # Keybindings that limit input and evaluate things
+ bind .eval.text <Return> { evaluate_tcl_command .eval.text ; break }
+ bind .eval.text <BackSpace> {
+ if [%W compare insert > cmdstart] {
+ %W delete {insert - 1 char} insert
} else {
- $fileselect(direntry) insert end [lindex $dirFile 0]/
- }
- fileselect.getfiles [$fileselect(direntry) get] \
- "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
- return
- }
- set headFile [fileselect.gethead $dirFile]
- $fileselect(direntry) delete 0 end
- $fileselect(direntry) insert 0 [file dirname $dir]
- if {[string compare [file dirname $dir] /]} {
- $fileselect(direntry) insert end /$headFile
- } else {
- $fileselect(direntry) insert end $headFile
- }
- if {$headFile == "" && [file isdirectory $dir]} {
- fileselect.getfiles $dir\
- "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
- } else {
- fileselect.getfiles [file dirname $dir]\
- "[file tail [$fileselect(direntry) get]]*" newdir
- }
-}
-
-proc fileselect.tab.filecmd { } {
- global fileselect
-
- set dir [$fileselect(direntry) get]
- if {$dir == ""} {
- set dir [pwd]
- }
- if {![file isdirectory $dir]} {
- error "dir $dir doesn't exist"
- }
- set listFile [fileselect.getfiledir 0 $dir]
- puts $listFile
- if {![llength $listFile]} {
- return
- }
- if {[llength $listFile] == 1} {
- $fileselect(entry) delete 0 end
- $fileselect(entry) insert 0 [lindex $listFile 0]
- return
- }
- set headFile [fileselect.gethead $listFile]
- $fileselect(entry) delete 0 end
- $fileselect(entry) insert 0 $headFile
- fileselect.getfiles $dir "[$fileselect(entry) get]$fileselect(pattern)" opt
-}
-
-proc Exwin_Toplevel { path name {class Dialog} {dismiss yes}} {
- global exwin
- if {[catch {wm state $path} state]} {
- set t [Widget_Toplevel $path $name $class]
- if {![info exists exwin(toplevels)]} {
- set exwin(toplevels) [option get . exwinPaths {}]
- }
- set ix [lsearch $exwin(toplevels) $t]
- if {$ix < 0} {
- lappend exwin(toplevels) $t
- }
- if {$dismiss == "yes"} {
- set f [Widget_Frame $t but Menubar {top fill}]
- Widget_AddBut $f quit "Dismiss" [list Exwin_Dismiss $path]
- }
- return 1
- } else {
- if {$state != "normal"} {
- catch {
- wm geometry $path $exwin(geometry,$path)
-# Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
- }
- wm deiconify $path
- } else {
- catch {raise $path}
- }
- return 0
- }
-}
-
-proc Exwin_Dismiss { path {geo ok} } {
- global exwin
- case $geo {
- "ok" {
- set exwin(geometry,$path) [wm geometry $path]
- }
- "nosize" {
- set exwin(geometry,$path) [string trimleft [wm geometry $path] 0123456789x]
- }
- default {
- catch {unset exwin(geometry,$path)}
+ bell
}
+ break
}
- wm withdraw $path
-}
-
-proc Widget_Toplevel { path name {class Dialog} {x {}} {y {}} } {
- set self [toplevel $path -class $class]
- set usergeo [option get $path position Position]
- if {$usergeo != {}} {
- if {[catch {wm geometry $self $usergeo} err]} {
-# Exmh_Debug Widget_Toplevel $self $usergeo => $err
- }
- } else {
- if {($x != {}) && ($y != {})} {
-# Exmh_Debug Event position $self +$x+$y
- wm geometry $self +$x+$y
+ bind .eval.text <Any-Key> {
+ if [%W compare insert < cmdstart] {
+ %W mark set insert end
}
}
- wm title $self $name
- wm group $self .
- return $self
-}
-
-proc Widget_Frame {par child {class GDB} {where {top expand fill}} args } {
- if {$par == "."} {
- set self .$child
- } else {
- set self $par.$child
- }
- eval {frame $self -class $class} $args
- pack append $par $self $where
- return $self
-}
-
-proc Widget_AddBut {par but txt cmd {where {right padx 1}} } {
- # Create a Packed button. Return the button pathname
- set cmd2 [list button $par.$but -text $txt -command $cmd]
- if {[catch $cmd2 t]} {
- puts stderr "Widget_AddBut (warning) $t"
- eval $cmd2 {-font fixed}
- }
- pack append $par $par.$but $where
- return $par.$but
-}
-
-proc Widget_CheckBut {par but txt var {where {right padx 1}} } {
- # Create a check button. Return the button pathname
- set cmd [list checkbutton $par.$but -text $txt -variable $var]
- if {[catch $cmd t]} {
- puts stderr "Widget_CheckBut (warning) $t"
- eval $cmd {-font fixed}
- }
- pack append $par $par.$but $where
- return $par.$but
-}
-
-proc Widget_Label { frame {name label} {where {left fill}} args} {
- set cmd [list label $frame.$name ]
- if {[catch [concat $cmd $args] t]} {
- puts stderr "Widget_Label (warning) $t"
- eval $cmd $args {-font fixed}
- }
- pack append $frame $frame.$name $where
- return $frame.$name
-}
-
-proc Widget_Entry { frame {name entry} {where {left fill}} args} {
- set cmd [list entry $frame.$name ]
- if {[catch [concat $cmd $args] t]} {
- puts stderr "Widget_Entry (warning) $t"
- eval $cmd $args {-font fixed}
+ bind .eval.text <Control-u> {
+ %W delete cmdstart "insert lineend"
+ %W see insert
}
- pack append $frame $frame.$name $where
- return $frame.$name
+ bindtags .eval.text {.eval.text Text all}
}
-# End of fileselect.tcl.
-
-#
-# Create a copyright window and center it on the screen. Arrange for
-# it to disappear when the user clicks it, or after a suitable period
-# of time.
-#
-proc create_copyright_window {} {
- toplevel .c
- message .c.m -text [gdb_cmd {show version}] -aspect 500 -relief raised
- pack .c.m
-
- bind .c.m <1> {destroy .c}
- bind .c <Leave> {destroy .c}
- # "suitable period" currently means "15 seconds".
- after 15000 {
- if {[winfo exists .c]} then {
- destroy .c
- }
- }
-
- wm transient .c .
- center_window .c
+# This proc is executed just prior to falling into the Tk main event loop.
+proc gdbtk_tcl_preloop {} {
+ global gdb_prompt
+ .cmd.text insert end "$gdb_prompt"
+ .cmd.text see end
+ update
}
# FIXME need to handle mono here. In Tk4 that is more complicated.
projects / deliverable / binutils-gdb.git / blobdiff