# Console window for Insight
# Copyright 1998, 1999, 2000, 2001, 2002, 2003 Red Hat, Inc.
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License (GPL) as published by
# the Free Software Foundation; either version 2 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
itcl::body Console::constructor {args} {
global gdbtk_state
window_name "Console Window"
debug "$args"
_build_win
eval itk_initialize $args
add_hook gdb_no_inferior_hook [list $this idle dummy]
# There are a bunch of console prefs that have no UI
# for the user to modify them. In the event that the user
# really wants to change them, they will have to be modified
# in prefs.tcl or by editing .gdbtkinit. When these prefs
# gain a prefs UI, the user may change them dynamically
# and the console window will need notification that they
# have changed. Add them to the following list and
# Console::_update_option.
foreach option {gdb/console/wrap} {
pref add_hook $option [code $this _update_option]
}
set gdbtk_state(console) $this
}
itcl::body Console::destructor {} {
global gdbtk_state
set gdbtk_state(console) ""
remove_hook gdb_no_inferior_hook [list $this idle dummy]
}
itcl::body Console::_build_win {} {
iwidgets::scrolledtext $itk_interior.stext \
-vscrollmode dynamic -textbackground white
set _twin [$itk_interior.stext component text]
_set_wrap [pref get gdb/console/wrap]
$_twin tag configure prompt_tag -foreground [pref get gdb/console/prompt_fg]
$_twin tag configure err_tag -foreground [pref get gdb/console/error_fg]
$_twin tag configure log_tag -foreground [pref get gdb/console/log_fg]
$_twin tag configure target_tag -foreground [pref get gdb/console/target_fg]
$_twin configure -font [pref get gdb/console/font] \
-bg $::Colors(textbg) -fg $::Colors(textfg)
#
# bind editing keys for console window
#
bind $_twin <Return> "$this invoke; break"
bind_plain_key $_twin Control-m "$this invoke; break"
bind_plain_key $_twin Control-j "$this invoke; break"
# History control.
bind_plain_key $_twin Control-p "[code $this _previous]; break"
bind $_twin <Up> "[code $this _previous]; break"
bind_plain_key $_twin Control-n "[code $this _next]; break"
bind $_twin <Down> "[code $this _next]; break"
bind $_twin <Meta-less> "[code $this _first]; break"
bind $_twin <Home> "[code $this _first]; break"
bind $_twin <Meta-greater> "[code $this _last]; break"
bind $_twin <End> "[code $this _last]; break"
bind_plain_key $_twin Control-o "[code $this _operate_and_get_next]; break"
# Tab completion
bind_plain_key $_twin KeyPress-Tab "[code $this _complete]; break"
# Don't let left arrow or ^B go over the prompt
bind_plain_key $_twin Control-b {
if {[%W compare insert <= {cmdmark + 1 char}]} {
break
}
}
bind $_twin <Left> [bind $_twin <Control-b>]
# Don't let Control-h, Delete, or Backspace back up over the prompt.
bind_plain_key $_twin Control-h "[code $this _delete]; break"
bind $_twin <BackSpace> "[code $this _delete]; break"
bind $_twin <Delete> "[code $this _delete 1]; break"
# Control-a moves to start of line.
bind_plain_key $_twin Control-a {
%W mark set insert {cmdmark + 1 char}
%W see {insert linestart}
break
}
# Control-u deletes to start of line.
bind_plain_key $_twin Control-u {
%W delete {cmdmark + 1 char} insert
%W see {insert linestart}
}
# Control-w deletes previous word.
bind_plain_key $_twin Control-w {
if {[%W compare {insert -1c wordstart} > cmdmark]} {
%W delete {insert -1c wordstart} insert
%W see insert
}
}
bind $_twin <Control-Up> "[code $this _search_history]; break"
bind $_twin <Shift-Up> "[code $this _search_history]; break"
bind $_twin <Control-Down> "[code $this _rsearch_history]; break"
bind $_twin <Shift-Down> "[code $this _rsearch_history]; break"
# Don't allow key motion to move insertion point outside the command
# area. This is done by fixing up the insertion point after any key
# movement. We only need to do this after events we do not
# explicitly override. Note that since the edit line is always the
# last line, we can't possibly go past it, so we don't bother
# checking that. Note also that we check for a binding which is
# simply `;'; this lets us handle keys already bound via
# bind_plain_key.
foreach event [bind Text] {
if {[string match *Key* $event]
&& ([bind $_twin $event] == ""
|| [bind $_twin $event] == ";")} {
bind $_twin $event [bind Text $event]
bind $_twin $event {+
if {[%W compare insert <= {cmdmark + 1 char}]} {
%W mark set insert {cmdmark + 1 char}
}
break
}
}
}
# Don't allow mouse to put cursor outside command line. For some
# events we do this by noticing when the cursor is outside the
# range, and then saving the insertion point. For others we notice
# the saved insertion point.
set pretag pre-$_twin
bind $_twin <1> [format {
if {[%%W compare [tk::TextClosestGap %%W %%x %%y] <= cmdmark]} {
%s _insertion [%%W index insert]
} else {
%s _insertion {}
}
} $this $this]
bind $_twin <B1-Motion> [format {
if {[%s _insertion] != ""} {
%%W mark set insert [%s _insertion]
}
} $this $this $this]
# FIXME: has inside information.
bind $_twin <ButtonRelease-1> [format {
tk::CancelRepeat
if {[%s _insertion] != ""} {
%%W mark set insert [%s _insertion]
}
%s _insertion {}
break
} $this $this $this]
# Don't allow inserting text outside the command line. FIXME:
# requires inside information.
# Also make it a little easier to paste by making the button
# drags a little "fuzzy".
bind $_twin <B2-Motion> {
if {!$tk_strictMotif} {
if {($tk::Priv(x) - 2 < %x < $tk::Priv(x) + 2) \
|| ($tk::Priv(y) - 2 < %y < $tk::Priv(y) + 2)} {
set tk::Priv(mouseMoved) 1
}
if {$tk::Priv(mouseMoved)} {
%W scan dragto %x %y
}
}
break
}
bind $_twin <ButtonRelease-2> [format {
if {!$tk::Priv(mouseMoved) || $tk_strictMotif} {
%s
break
}
} [code $this _paste 1]]
bind $_twin <<Paste>> "[code $this _paste 0]; break"
bind $_twin <<PasteSelection>> "[code $this _paste 0]; break"
bind_plain_key $_twin Control-c "event generate $_twin <<Copy>>"
bind_plain_key $_twin Control-v "[code $this _paste 1]; break"
_setprompt
pack $itk_interior.stext -expand yes -fill both
focus $_twin
}
itcl::body Console::idle {event} {
set _running 0
$_top configure -cursor {}
}
# ------------------------------------------------------------------
# METHOD: busy - busy event handler
# ------------------------------------------------------------------
itcl::body Console::busy {event} {
set _running 1
$_top configure -cursor watch
}
# ------------------------------------------------------------------
# METHOD: insert - insert new text in the text widget
# ------------------------------------------------------------------
itcl::body Console::insert {line {tag ""}} {
if {$_needNL} {
$_twin insert {insert linestart} "\n"
}
# Remove all \r characters from line.
set line [join [split $line \r] {}]
$_twin insert {insert -1 line lineend} $line $tag
set nlines [lindex [split [$_twin index end] .] 0]
if {$nlines > $throttle} {
set delta [expr {$nlines - $throttle}]
$_twin delete 1.0 ${delta}.0
}
$_twin see insert
set _needNL 0
::update idletasks
}
# ------------------------------------------------------------------
# NAME: ConsoleWin::_operate_and_get_next
# DESCRIPTION: Invokes the current command and, if this
# command came from the history, arrange for
# the next history command to be inserted once this
# command is finished.
#
# ARGUMENTS: None
# RETURNS: Nothing
# ------------------------------------------------------------------
itcl::body Console::_operate_and_get_next {} {
if {$_histElement >= 0} {
# _pendingHistElement will be used after the new history element
# is pushed. So we must increment it.
set _pendingHistElement [expr {$_histElement + 1}]
}
invoke
}
#-------------------------------------------------------------------
# METHOD: _previous - recall the previous command
# ------------------------------------------------------------------
itcl::body Console::_previous {} {
if {$_histElement == -1} {
# Save partial command.
set _partialCommand [$_twin get {cmdmark + 1 char} {cmdmark lineend}]
}
incr _histElement
set text [lindex $_history $_histElement]
if {$text == ""} {
# No dice.
incr _histElement -1
# FIXME flash window.
} else {
$_twin delete {cmdmark + 1 char} {cmdmark lineend}
$_twin insert {cmdmark + 1 char} $text
}
}
#-------------------------------------------------------------------
# METHOD: _search_history - search history for match
# ------------------------------------------------------------------
itcl::body Console::_search_history {} {
set str [$_twin get {cmdmark + 1 char} {cmdmark lineend}]
if {$_histElement == -1} {
# Save partial command.
set _partialCommand $str
set ix [lsearch $_history ${str}*]
} else {
set str $_partialCommand
set num [expr $_histElement + 1]
set ix [lsearch [lrange $_history $num end] ${str}*]
incr ix $num
}
set text [lindex $_history $ix]
if {$text != ""} {
set _histElement $ix
$_twin delete {cmdmark + 1 char} {cmdmark lineend}
$_twin insert {cmdmark + 1 char} $text
}
}
#-------------------------------------------------------------------
# METHOD: _rsearch_history - search history in reverse for match
# ------------------------------------------------------------------
itcl::body Console::_rsearch_history {} {
if {$_histElement != -1} {
set str $_partialCommand
set num [expr $_histElement - 1]
set ix $num
while {$ix >= 0} {
if {[string match ${str}* [lindex $_history $ix]]} {
break
}
incr ix -1
}
set text ""
if {$ix >= 0} {
set text [lindex $_history $ix]
set _histElement $ix
} else {
set text $_partialCommand
set _histElement -1
}
$_twin delete {cmdmark + 1 char} {cmdmark lineend}
$_twin insert {cmdmark + 1 char} $text
}
}
#-------------------------------------------------------------------
# METHOD: _next - recall the next command (scroll forward)
# ------------------------------------------------------------------
itcl::body Console::_next {} {
if {$_histElement == -1} {
# FIXME flash window.
return
}
incr _histElement -1
if {$_histElement == -1} {
set text $_partialCommand
} else {
set text [lindex $_history $_histElement]
}
$_twin delete {cmdmark + 1 char} {cmdmark lineend}
$_twin insert {cmdmark + 1 char} $text
}
#-------------------------------------------------------------------
# METHOD: _last - get the last history element
# ------------------------------------------------------------------
itcl::body Console::_last {} {
set _histElement 0
_next
}
#-------------------------------------------------------------------
# METHOD: _first - get the first (earliest) history element
# ------------------------------------------------------------------
itcl::body Console::_first {} {
set _histElement [expr {[llength $_history] - 1}]
_previous
}
#-------------------------------------------------------------------
# METHOD: _setprompt - put a prompt at the beginning of a line
# ------------------------------------------------------------------
itcl::body Console::_setprompt {{prompt {}}} {
if {$prompt == ""} {
#set prompt [pref get gdb/console/prompt]
set prompt [gdb_prompt]
} elseif {$prompt == "none"} {
set prompt ""
}
$_twin delete {insert linestart} {insert lineend}
$_twin insert {insert linestart} $prompt prompt_tag
$_twin mark set cmdmark "insert -1 char"
$_twin see insert
if {$_pendingHistElement >= 0} {
set _histElement $_pendingHistElement
set _pendingHistElement -1
_next
}
}
#-------------------------------------------------------------------
# METHOD: gets - get a line of input from the console
# ------------------------------------------------------------------
itcl::body Console::gets {} {
set _input_mode 1
# _setprompt "(input) "
_setprompt none
$_twin delete insert end
$_twin mark set cmdmark {insert -1 char}
bind_plain_key $_twin Control-d "$this invoke 1; break"
bind_plain_key $_twin Control-c "[code $this _cancel]; break"
vwait [scope _input_result]
set _input_mode 0
bind_plain_key $_twin Control-c "event generate $_twin <<Copy>>"
activate
if {$_input_error} {
set _input_error 0
return -code error ""
}
return $_input_result
}
#-------------------------------------------------------------------
# METHOD: cancel - cancel input when ^C is hit
# ------------------------------------------------------------------
itcl::body Console::_cancel {} {
if {$_input_mode} {
set _needNL 1
$_twin mark set insert {insert lineend}
$_twin insert {insert lineend} "^C\n"
incr _invoking
set _input_error 1
set _input_result ""
}
}
#-------------------------------------------------------------------
# METHOD: activate - run this after a command is run
# ------------------------------------------------------------------
itcl::body Console::activate {{prompt {}}} {
if {$_invoking > 0} {
incr _invoking -1
_setprompt $prompt
}
}
#-------------------------------------------------------------------
# METHOD: invoke - invoke a command
# ------------------------------------------------------------------
itcl::body Console::invoke {{controld 0}} {
global gdbtk_state
set text [$_twin get {cmdmark + 1 char} end ]
if { "[string range $text 0 1]" == "tk" } {
if {! [info complete $text] } {
$_twin insert {insert lineend} " \\\n"
$_twin see insert
return
}
}
incr _invoking
set text [string trimright $text \n]
if {$text == ""} {
set text [lindex $_history 0]
$_twin insert {insert lineend} $text
}
$_twin mark set insert {insert lineend}
$_twin insert {insert lineend} "\n"
set ok 0
if {$_running} {
if {[string index $text 0] == "!"} {
set text [string range $text 1 end]
set ok 1
}
}
if {$_input_mode} {
if {!$controld} {append text \n}
set _input_result $text
set _needNL 1
return
}
# Only push new nonempty history items.
if {$text != "" && [lindex $_history 0] != $text} {
lvarpush _history $text
}
set index [$_twin index insert]
# Clear current history element, and current partial element.
set _histElement -1
set _partialCommand ""
# Need a newline before next insert.
set _needNL 1
# run command
if {$gdbtk_state(readline)} {
set gdbtk_state(readline_response) $text
return
}
if {!$_running || $ok} {
set result [catch {gdb_immediate "$text" 1} message]
} else {
set result 1
set message "The debugger is busy."
}
# gdb_immediate may take a while to finish. Exit if
# our window has gone away.
if {![winfo exists $_twin]} { return }
if {$result} {
global errorInfo
dbug W "Error: $errorInfo\n"
$_twin insert end "Error: $message\n" err_tag
} elseif {$message != ""} {
$_twin insert $index "$message\n"
}
# Make the prompt visible again.
activate
# Make sure the insertion point is visible.
$_twin see insert
}
#-------------------------------------------------------------------
# PRIVATE METHOD: _delete - Handle a Delete of some sort.
# ------------------------------------------------------------------
itcl::body Console::_delete {{right 0}} {
# If we are deleting to the right, and we have this turned off,
# delete to the right.
if {$right && ![pref get gdb/console/deleteLeft]} {
set right 0
}
if {!$right} {
set insert_valid [$_twin compare insert > {cmdmark + 1 char}]
set delete_loc "insert-1c"
} else {
set insert_valid [$_twin compare insert > cmdmark]
set delete_loc "insert"
}
# If there is a selection on the command line, delete it,
# If there is a selection above the command line, do a
# regular delete, but don't delete the prompt.
# If there is no selection, do the delete.
if {![catch {$_twin index sel.first}]} {
if {[$_twin compare sel.first <= cmdmark]} {
if {$insert_valid} {
$_twin delete $delete_loc
}
} else {
$_twin delete sel.first sel.last
}
} elseif {$insert_valid} {
$_twin delete $delete_loc
}
}
#-------------------------------------------------------------------
# PRIVATE METHOD: _insertion - Set or get saved insertion point
# ------------------------------------------------------------------
itcl::body Console::_insertion {args} {
if {! [llength $args]} {
return $_saved_insertion
} else {
set _saved_insertion [lindex $args 0]
}
}
# ------------------------------------------------------------------
# METHOD: _paste - paste the selection into the console window
# ------------------------------------------------------------------
itcl::body Console::_paste {{check_primary 1}} {
set sel {}
if {!$check_primary || [catch {selection get} sel] || $sel == ""} {
if {[catch {selection get -selection CLIPBOARD} sel] || $sel == ""} {
return
}
}
#if there is a selection, insert over it:
if {![catch {$_twin index sel.first}]
&& [$_twin compare sel.first > {cmdmark + 1 char}]} {
set point [$_twin index sel.first]
$_twin delete sel.first sel.last
$_twin insert $point $sel
} else {
$_twin insert insert $sel
}
}
# ------------------------------------------------------------------
# METHOD: _find_lcp - Return the longest common prefix in SLIST.
# Can be empty string.
# ------------------------------------------------------------------
itcl::body Console::_find_lcp {slist} {
# Handle trivial cases where list is empty or length 1
if {[llength $slist] <= 1} {return [lindex $slist 0]}
set prefix [lindex $slist 0]
set prefixlast [expr [string length $prefix] - 1]
foreach str [lrange $slist 1 end] {
set test_str [string range $str 0 $prefixlast]
while {[string compare $test_str $prefix] != 0} {
incr prefixlast -1
set prefix [string range $prefix 0 $prefixlast]
set test_str [string range $str 0 $prefixlast]
}
if {$prefixlast < 0} break
}
return $prefix
}
# ------------------------------------------------------------------
# METHOD: _find_completion - Look through COMPLETIONS to generate
# the suffix needed to do command
# ------------------------------------------------------------------
itcl::body Console::_find_completion {cmd completions} {
# Get longest common prefix
set lcp [_find_lcp $completions]
set cmd_len [string length $cmd]
# Return suffix beyond end of cmd
return [string range $lcp $cmd_len end]
}
# ------------------------------------------------------------------
# METHOD: _complete - Command line completion
# ------------------------------------------------------------------
itcl::body Console::_complete {} {
set command_line [$_twin get {cmdmark + 1 char} {cmdmark lineend}]
set choices [gdb_cmd "complete $command_line" 1]
set choices [string trimright $choices \n]
set choices [split $choices \n]
# Just do completion if this is the first tab
if {!$_saw_tab} {
set _saw_tab 1
set completion [_find_completion $command_line $choices]
# Here is where the completion is actually done. If there
# is one match, complete the command and print a space.
# If two or more matches, complete the command and beep.
# If no match, just beep.
switch [llength $choices] {
0 {}
1 {
$_twin insert end "$completion "
set _saw_tab 0
return
}
default {
$_twin insert end $completion
}
}
bell
$_twin see end
bind $_twin <KeyPress> [code $this _reset_tab]
} else {
# User hit another consecutive tab. List the choices.
# Note that at this point, choices may contain commands
# with spaces. We have to lop off everything before (and
# including) the last space so that the completion list
# only shows the possibilities for the last token.
set choices [lsort $choices]
if {[regexp ".* " $command_line prefix]} {
regsub -all $prefix $choices {} choices
}
if {[llength choices] != 0} {
insert "\nCompletions:\n[join $choices \ ]\n"
$_twin see end
bind $_twin <KeyPress> [code $this _reset_tab]
}
}
}
# ------------------------------------------------------------------
# METHOD: _reset_tab - Helper method for tab completion. Used
# to reset the tab when a key is pressed.
# ------------------------------------------------------------------
itcl::body Console::_reset_tab {} {
bind $_twin <KeyPress> {}
set _saw_tab 0
}
# ------------------------------------------------------------------
# METHOD: _set_wrap - Set wrap mode
# ------------------------------------------------------------------
itcl::body Console::_set_wrap {wrap} {
if { $wrap } {
set hsm none
set wv char
} else {
set hsm dynamic
set wv none
}
$itk_interior.stext configure -hscrollmode $hsm
$_twin configure -wrap $wv
}
# ------------------------------------------------------------------
# METHOD: _update_option - Update in response to preference change
# ------------------------------------------------------------------
itcl::body Console::_update_option {name value} {
switch -- $name {
gdb/console/wrap {
_set_wrap $value
}
gdb/console/prompt_fg {
$_twin tag configure prompt_tag -foreground $value
}
gdb/console/error_fg {
$_twin tag configure err_tag -foreground $value
}
}
}
# ------------------------------------------------------------------
# NAME: public method Console::test
# DESCRIPTION: Executes the given command
#
# ARGUMENTS: Command to run
# RETURNS: Return value of command
#
# NOTES: This will only run if env(GDBTK_TEST_RUNNING)==1.
# FOR TESTING ONLY
# ------------------------------------------------------------------
itcl::body Console::test {args} {
global env
if {[info exists env(GDBTK_TEST_RUNNING)] && $env(GDBTK_TEST_RUNNING) == 1} {
return [eval $args]
}
}