share/insight1.0/console.itb

# Console window for Insight
# Copyright (C) 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]
  }
}