# Console window for GDBtk # Copyright 1998, 1999 Cygnus Solutions # # 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. body Console::constructor {args} { global gdbtk_state window_name "Console Window" debug "$args" _build_win eval itk_initialize $args add_hook gdb_busy_hook [list $this busy] add_hook gdb_idle_hook [list $this idle] add_hook gdb_no_inferior_hook [list $this idle] set gdbtk_state(console) $this } body Console::destructor {} { global gdbtk_state set gdbtk_state(console) "" remove_hook gdb_busy_hook [list $this busy] remove_hook gdb_idle_hook [list $this idle] remove_hook gdb_no_inferior_hook [list $this idle] } body Console::_build_win {} { set wrap [pref get gdb/console/wrap] if { $wrap } { set hsm none } else { set hsm dynamic } iwidgets::scrolledtext $itk_interior.stext -hscrollmode $hsm \ -vscrollmode dynamic -textbackground white set _twin [$itk_interior.stext component text] if {$wrap} { $_twin configure -wrap word } else { $_twin configure -wrap none } $_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 configure -font [pref get gdb/console/font] # # bind editing keys for console window # bind $_twin <Return> "$this invoke; break" # disable this bind_plain_key $_twin Control-o "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" # 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. foreach event [bind Text] { if {[string match *Key* $event] && [bind $_twin $event] == ""} { bind $_twin $event { if {[%W compare insert <= {cmdmark + 1 char}]} { %W mark set insert {cmdmark + 1 char} } } } } # 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 [tkTextClosestGap %%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 { tkCancelRepeat 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 {($tkPriv(x) - 2 < %x < $tkPriv(x) + 2) \ || ($tkPriv(y) - 2 < %y < $tkPriv(y) + 2)} { set tkPriv(mouseMoved) 1 } if {$tkPriv(mouseMoved)} { %W scan dragto %x %y } } break } bind $_twin <ButtonRelease-2> [format { if {!$tkPriv(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" _setprompt pack $itk_interior.stext -expand yes -fill both focus $_twin } body Console::idle {} { set _running 0 } body Console::busy {} { set _running 1 } # ------------------------------------------------------------------ # METHOD: insert - insert new text in the text widget # ------------------------------------------------------------------ body Console::insert {line} { 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 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 } #------------------------------------------------------------------- # METHOD: einsert - insert error text in the text widget # ------------------------------------------------------------------ body Console::einsert {line} { debug $line if {$_needNL} { $_twin insert end "\n" } $_twin insert end $line err_tag $_twin see insert set _needNL 0 } #------------------------------------------------------------------- # METHOD: _previous - recall the previous command # ------------------------------------------------------------------ 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 # ------------------------------------------------------------------ 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 # ------------------------------------------------------------------ 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) # ------------------------------------------------------------------ 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 # ------------------------------------------------------------------ body Console::_last {} { set _histElement 0 _next } #------------------------------------------------------------------- # METHOD: _first - get the first (earliest) history element # ------------------------------------------------------------------ body Console::_first {} { set _histElement [expr {[llength $_history] - 1}] _previous } #------------------------------------------------------------------- # METHOD: _setprompt - put a prompt at the beginning of a line # ------------------------------------------------------------------ body Console::_setprompt {{prompt {}}} { if {$_invoking} { set prompt "" } elseif {"$prompt" != ""} { # nothing } else { #set prompt [pref get gdb/console/prompt] set prompt [gdb_prompt] } $_twin insert {insert linestart} $prompt prompt_tag $_twin mark set cmdmark "insert -1 char" $_twin see insert } #------------------------------------------------------------------- # METHOD: activate - run this after a command is run # ------------------------------------------------------------------ body Console::activate {{prompt {}}} { if {$_invoking > 0} { incr _invoking -1 _setprompt $prompt } } #------------------------------------------------------------------- # METHOD: invoke - invoke a command # ------------------------------------------------------------------ body Console::invoke {} { global gdbtk_state incr _invoking set text [$_twin get {cmdmark + 1 char} {cmdmark lineend}] 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 } } # 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. # ------------------------------------------------------------------ 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 # ------------------------------------------------------------------ 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 # ------------------------------------------------------------------ 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 } } # public method for testing only body Console::get_text {} { return $_twin } # ------------------------------------------------------------------ # METHOD: _find_lcp - Return the longest common prefix in SLIST. # Can be empty string. # ------------------------------------------------------------------ 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 # ------------------------------------------------------------------ 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 # ------------------------------------------------------------------ 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. # ------------------------------------------------------------------ body Console::_reset_tab {} { bind $_twin <KeyPress> {} set _saw_tab 0 }