#!/usr/locanl/bin/tclsh
# FILE: "/diska/home/joze/src/tclreadline/tclreadlineSetup.tcl.in"
# LAST MODIFICATION: "Mon Sep 6 08:50:52 1999 (joze)"
# (C) 1998, 1999 by Johannes Zellner, <johannes@zellner.org>
# $Id$
# ---
#
# tclreadline -- gnu readline for tcl
# Copyright (C) 1999 Johannes Zellner
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# 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.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#
# johannes@zellner.org
# http://www.zellner.org/tclreadline/
#
# ==================================================================
# done:
#
# - append
# - array
# - bgerror
# - binary
# - break
# - catch
# - cd
# - clock
# - close
# - concat
# - continue
# - (ddd is only on M$)
# - encoding
# - eof
# - error
# - eval
# - exec
# - exit
# - expr
# - fblocked
# - fconfigure
# - fcopy
# - file
# - fileevent
# - flush
# - for # TODO
# - foreach # TODO
# - format # TODO
# - gets
# - glob
# - global
# - if # TODO
# - incr
# - index
# - info
# - interp
# - join
# - lappend
# - llength
# - linsert
# - list
# - load
# - lrange
# - lreplace
# - lsearch
# - lsort
# - history
# - load
# - namespace
# - open
# - package
# - pkg_mkIndex
# - proc
# - puts
# - pwd
# - pid
# - read
# - regexp
# - (registry is only on M$)
# - regsub
# - rename
# - (resource is on mac only)
# - return
# - scan # TODO
# - seek
# - socket
# - source
# - split # TODO
# - string
# - subst
# - switch
# - tell
# - time # TODO ??
# - trace
# - set
# - unknown
# - unset
# - update
# - uplevel
# - upvar
# - variable
# - vwait
# - while # TODO
#
# package provide tclreadline @TCLREADLINE_VERSION@
package provide tclreadline 0.9
proc unknown args {
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
# Save the values of errorCode and errorInfo variables, since they
# may get modified if caught errors occur below. The variables will
# be restored just before re-executing the missing command.
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
set name [lindex $args 0]
if ![info exists auto_noload] {
#
# Make sure we're not trying to load the same proc twice.
#
if [info exists unknown_pending($name)] {
return -code error "self-referential recursion in \"unknown\" for command \"$name\""
}
set unknown_pending($name) pending
set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
unset unknown_pending($name)
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
"error while autoloading \"$name\": $msg"
}
if ![array size unknown_pending] {
unset unknown_pending
}
if $msg {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set code [catch {uplevel 1 $args} msg]
if {$code == 1} {
#
# Strip the last five lines off the error stack (they're
# from the "uplevel" command).
#
set new [split $errorInfo \n]
set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
return -code error -errorcode $errorCode \
-errorinfo $new $msg
} else {
return -code $code $msg
}
}
}
# REMOVED THE [info script] TEST (joze, SEP 98)
if {([info level] == 1) \
&& [info exists tcl_interactive] && $tcl_interactive} {
if ![info exists auto_noexec] {
set new [auto_execok $name]
if {$new != ""} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set redir ""
if {[info commands console] == ""} {
set redir ">&@stdout <@stdin"
}
# LOOK FOR GLOB STUFF IN $ARGS (joze, SEP 98)
return [uplevel eval exec $redir $new \
[::tclreadline::Glob [lrange $args 1 end]]]
}
}
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
if {$name == "!!"} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name dummy event]} {
set newcmd [history event $event]
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
if [info exists newcmd] {
tclLog $newcmd
history change $newcmd 0
return [uplevel $newcmd]
}
set ret [catch {set cmds [info commands $name*]} msg]
if {[string compare $name "::"] == 0} {
set name ""
}
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
"error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
}
if {[llength $cmds] == 1} {
return [uplevel [lreplace $args 0 0 $cmds]]
}
if {[llength $cmds] != 0} {
if {$name == ""} {
return -code error "empty command name \"\""
} else {
return -code error \
"ambiguous command name \"$name\": [lsort $cmds]"
}
}
}
return -code error "invalid command name \"$name\""
}
namespace eval tclreadline {
namespace export Setup Glob Loop InitCmds InitTclCmds InitTkCmds Print ls
proc FirstNonOption {line} {
set expr_pos 1
foreach word [lrange ${line} 1 end] {; # 0 is the command itself
if {"-" != [string index ${word} 0]} {
break
} else {
incr expr_pos
}
}
return ${expr_pos}
}
proc RemoveUsedOptions {line opts {terminate {}}} {
if {[llength ${terminate}]} {
if {[regexp -- ${terminate} ${line}]} {
return ""
}
}
set new ""
foreach word ${opts} {
if {![regexp -- ${word} ${line}]} {
lappend new ${word}
}
}
return [string trim ${new}]
}
proc Alert {} {
puts -nonewline \a
flush stdout
}
# AttemptFromList will return an empty string, if
# the text typed so far does not match any of the
# elements in list. This might be used to allow
# subsequent filename completion by the builtin
# completer.
#
proc AttemptFromList {text lst} {
return [string trim [Format [FindInList $text $lst] $text]]
}
# CompleteFromList will never return an empty string.
#
proc CompleteFromList {text lst} {
set result [AttemptFromList ${text} ${lst}]
if {![llength ${result}]} {
Alert
return [string trim "${text} ${lst}"]
} else {
return ${result}
}
}
# ???????
proc MenuFromList {text lst} {
if {![llength ${text}]} {
return [string trim "{} ${lst}"]
} else {
return [AttemptFromList ${text} ${lst}]
}
}
# never return an empty string
#
proc Menu {lst} {
return [string trim "{} ${lst}"]
}
proc FindInList {text lst} {
set result ""
foreach word $lst {
if {[string match ${text}* ${word}]} {
lappend result ${word}
}
}
return [string trim $result]
}
# get the longest common completion
# e.g. str == {tcl_version tclreadline_version tclreadline_library}
# --> [GetCommon ${str}] == "tcl"
#
proc GetCommon {str} {
# puts stderr str=$str
set match0 [lindex ${str} 0]
set len0 [string length $match0]
set no_matches [llength ${str}]
set part ""
for {set i 0} {$i < $len0} {incr i} {
set char [string index $match0 $i]
for {set j 1} {$j < $no_matches} {incr j} {
if {$char != [string index [lindex ${str} $j] $i]} {
break
}
}
if {$j < $no_matches} {
break
} else {
append part $char
}
}
# puts stderr part=$part
return ${part}
}
proc SubCmd {start line} {
set depth 0
# puts stderr SubCmd
for {set i $start} {$i >= 0} {incr i -1} {
set c [string index $line $i]
if {{;} == $c} {
incr i; # discard command break character
return [list [expr $start - $i] [string range $line $i end]]
} elseif {{]} == $c} {
incr depth
} elseif {{[} == $c} {
incr depth -1
if {$depth < 0} {
incr i; # discard command break character
return [list [expr $start - $i] [string range $line $i end]]
}
}
}
return ""
}
proc IsWhite {char} {
if {" " == $char || "\n" == $char || "\t" == $char} {
return 1
} else {
return 0
}
}
proc PreviousWord {start line} {
incr start -1
set found 0
for {set i $start} {$i > 0} {incr i -1} {
set c [string index $line $i]
if {${found} && [IsWhite $c]} {
break
} elseif {!${found} && ![IsWhite $c]} {
set found 1
}
}
return [string trim [string range ${line} $i $start]]
}
proc Quote {value left} {
set right [Right ${left}]
if {1 < [llength $value] && "" == $right} {
return [list \"${value}\"]
} else {
return [list ${left}${value}${right}]
}
}
proc InChannelId {text} {
return [ChannelId ${text} <inChannel> {stdin}]
}
proc OutChannelId {text} {
return [ChannelId ${text} <outChannel> {stdout stderr}]
}
proc ChannelId {text {default <channelId>} {chs {stdin stdout stderr}}} {
if {[llength ${text}]} {
set channel [AttemptFromList $text ${chs}]
if {[llength [lindex ${channel} 0]]} {
return ${channel}
} else {
return ""
}
}
return ${default}
}
proc QuoteQuotes {line} {
regsub -all -- \" $line {\"} line
regsub -all -- \{ $line {\{} line; # \}\} (keep the editor happy)
return $line
}
#**
# get the word position.
# @return the word position
# @note will returned modified values.
# @sa EventuallyEvaluateFirst
# @date Sep-06-1999
#
# % p<TAB>
# % bla put<TAB> $b
# % put<TAB> $b
# part == put
# start == 0
# end == 3
# line == "put $b"
# [PartPosition] should return 0
#
proc PartPosition {partT startT endT lineT} {
upvar $partT part $startT start $endT end $lineT line
EventuallyEvaluateFirst part start end line
# puts stderr "(PartPosition) line\[start\]=[string index $line $start]"
# puts stderr "(PartPosition) part=|$part|"
incr start -1
if {"\"" == [string index $line $start]} {
incr start -1
}
# puts stderr "(PartPosition) line=|$line|"
# puts stderr "(PartPosition) start=$start"
set line [string range $line 0 $start]
set line [QuoteQuotes $line]
# puts stderr "(PartPosition) line=|$line|"
set result [llength $line]
# puts stderr $result
return $result
}
proc Right {left} {
if {"\"" == $left} {
return ""
} elseif {"\{" == $left} {
return "\}"
} elseif {"\\\{" == $left} {
return "\\\}"
}
return ""
}
proc GetPrefix {text} {
set null [string index $text 0]
# puts null=|$null|
if {"\"" == $null} {
# puts stderr \neins\n
set pre "\\\""
} elseif {"\{" == $null} {
# puts stderr \nzwei\n
set pre "\\\{"
} else {
# puts stderr \ndrei\n
set pre ""
}
return ${pre}
}
proc Format {matches {part {}}} {
# puts matches=|$matches|
# puts stderr \npart=|$part|\n
set pre [GetPrefix ${part}]
if {1 == [llength $matches]} { ; # unique match
# puts stderr \nunique=$matches\n
# puts stderr "\n|${pre}${matches}[Right ${pre}]|\n"
return [string trim ${pre}${matches}[Right ${pre}]]
} elseif {"" != ${matches}} {
# puts stderr \nmore=$matches\n
set common [GetCommon ${matches}]
# puts stderr common=|$common|
if {"" == $common} {
return [string trim "[list $part] ${matches}"]
} else {
return [string trim "${pre}${common} ${matches}"]
}
} else {
return ""; # nothing to complete
}
}
proc ListCompletion {text {level -1}} {
# TODO
return ""
# return [VarCompletion ${text} ${level}]
}
proc VarCompletion {text {level -1}} {
if {-1 == ${level}} {
set level [info level]
} else {
incr level
}
set pre [GetPrefix ${text}]
if {"" == ${pre}} {
set var ${text}
} else {
set var [string range ${text} 1 end]
}
# arrays
#
if {[regexp {([^(]*)\((.*)} ${var} all array name]} {
set names [uplevel ${level} array names ${array} ${name}*]
if {1 == [llength $names]} { ; # unique match
return "${array}(${names})"
} elseif {"" != ${names}} {
return "${array}([GetCommon ${names}] ${names}"
} else {
return ""; # nothing to complete
}
}
# non-arrays
#
regsub ":$" ${var} "::" var
set namespaces [namespace children :: ${var}*]
if {[llength ${namespaces}] && "::" != [string range ${var} 0 1]} {
foreach name ${namespaces} {
regsub "^::" ${name} "" name
if {[string length ${name}]} {
lappend new ${name}::
}
}
set namespaces ${new}
unset new
}
set matches \
[string trim "[uplevel ${level} info vars ${var}*] ${namespaces}"]
if {1 == [llength $matches]} { ; # unique match
# check if this unique match is an
# array name, (whith no "(" yet).
#
if {[uplevel ${level} array exists $matches]} {
return [VarCompletion ${matches}( ${level}]; # recursion
} else {
return ${pre}${matches}[Right ${pre}]
}
} elseif {"" != $matches} { ; # more than one match
set common [GetCommon ${matches}]
if {"" == ${common}} {
return [Format ${matches} ${text}]
} else {
return [string trim "${pre}${common} ${matches}"]
}
} else {
return ""; # nothing to complete
}
}
proc FullQualifiedMatches {qualifier matchlist} {
set new ""
foreach entry ${matchlist} {
set full ${qualifier}::${entry}
if {"" != [namespace which ${full}]} {
lappend new ${full}
}
}
return ${new}
}
proc ProcsOnlyCompletion {cmd} {
return [CommandCompletion ${cmd} procs]
}
proc CommandsOnlyCompletion {cmd} {
return [CommandCompletion ${cmd} commands]
}
proc CommandCompletion {cmd {action both} {spc ::}} {
set quali [namespace qualifiers ${cmd}]
if {[llength ${quali}]} {
set rec [CommandCompletion [namespace tail ${cmd}] ${action} ${quali}]
return [FullQualifiedMatches ${quali} ${rec}]
}
# puts stderr \ncmd=|$cmd|\n
set cmd [string trim ${cmd}]*
if {"procs" != ${action}} {
set commands [namespace eval $spc "info commands [QuoteQuotes ${cmd}]"]
# puts stderr commands=|$commands|
} else {
set commands ""
}
if {"commands" != ${action}} {
set procs [namespace eval $spc "info procs [QuoteQuotes ${cmd}]"]
# puts stderr procs=|$procs|
} else {
set procs ""
}
set matches [namespace eval $spc concat ${commands} ${procs}]
#
# foreach match ${matches} {
# set full ${spc}::${match}
# if {"" != [namespace which ${full}]} {
# lappend new bla::${full}
# }
# }
#
set namespaces [namespace children $spc ${cmd}]
if {![llength ${matches}] && 1 == [llength ${namespaces}]} {
set namespaces [string trim ${namespaces}]
regsub {^([^:])} $namespaces {::\1} namespaces
# set matches [namespace eval ${namespaces} \
# {concat [info commands] [info procs]}]
if {"procs" != ${action}} {
set n_commands [namespace eval ${namespaces} "info commands"]
} else {
set n_commands ""
}
if {"commands" != ${action}} {
set n_procs [namespace eval ${namespaces} "info procs"]
} else {
set n_procs ""
}
set matches [string trim "${n_commands} ${n_procs}"]
if {[llength ${matches}]} {
#
# foreach match ${matches} {
# set full ${namespaces}::${match}
# if {"" != [namespace which ${full}]} {
# lappend new ${namespaces}::${match}
# }
# }
#
# set matches ${new}
# unset new
#
set matches [FullQualifiedMatches ${namespaces} ${matches}]
set namespaces ""
}
}
return [string trim "${matches} ${namespaces}"]
}
#**
# check, if the first argument starts with a '['
# and must be evaluated before continuing.
# NOTE: eventually modifies all arguments.
# DATE: Sep-06-1999
#
proc EventuallyEvaluateFirst {partT startT endT lineT} {
# return; # disabled
upvar $partT part $startT start $endT end $lineT line
set line [string trim ${line}]
set char [string index ${line} 0]
if {{[} != ${char} && {$} != ${char}} {return}
set pos 0
while {-1 != [set idx [string first {]} ${line} ${pos}]]} {
set cmd [string range ${line} 0 ${idx}]
if {[info complete ${cmd}]} {
break;
}
set pos [expr ${idx} + 1]
}
if {![info exists cmd]} {return}
if {![info complete ${cmd}]} {return}
set cmd [string range ${cmd} 1 [expr [string length ${cmd}] - 2]]
set rest [string range ${line} [expr ${idx} + 1] end]
if {[catch [list set result [string trim [eval ${cmd}]]]]} {return}
set line ${result}${rest}
set diff [expr [string length ${result}] - ([string length ${cmd}] + 2)]
incr start ${diff}
incr end ${diff}
}
# if the line entered so far is
# % puts $b<TAB>
# part == $b
# start == 5
# end == 7
# line == "$puts $b"
#
proc ScriptCompleter {part start end line} {
# puts stderr "(ScriptCompleter) |$part| $start $end |$line|"
variable known_cmds
if {{$} == [string index $part 0]} {
# check for a !$ history event
#
if {$start > 0} {
if {{!} == [string index $line [expr $start - 1]]} {
return ""
}
}
# variable completion. Check first, if the
# variable starts with a plain `$' or should
# be enclosed in braces.
#
set var [string range $part 1 end]
#
# if {"\{" == [string index $part 1]} {
# set var [string range $part 2 end]
# set left "\{"
# } else {
# set left ""
# set var [string range $part 1 end]
# }
#
# check if $var is an array name, which
# already has already a "(" somewhere inside.
#
if {"" != [set vc [VarCompletion $var]]} {
if {"" == [lindex $vc 0]} {
return "\$ [lrange ${vc} 1 end]"
} else {
return \$${vc}
}
# puts stderr vc=|$vc|
} else {
return ""
}
# SCENARIO:
#
# % puts bla; put<TAB> $b
# part == put
# start == 10
# end == 13
# line == "puts bla; put $b"
# [SubCmd] --> {1 " put $b"} == sub
# new_start = [lindex $sub 0] == 1
# new_end = [expr $end - ($start - $new_start)] == 4
# new_part == $part == put
# new_line = [lindex $sub 1] == " put $b"
#
} elseif {"" != [set sub [SubCmd $start $line]]} {
set new_start [lindex $sub 0]
set new_end [expr $end - ($start - $new_start)]
set new_line [lindex $sub 1]
# puts stderr "(SubCmd) $new_start $new_end $new_line"
return [ScriptCompleter $part $new_start $new_end $new_line]
} elseif {0 == [set pos [PartPosition part start end line]]} {
# puts stderr "(PartPosition) $part $start $end $line"
# set matches [array names known_cmds "[string trim ${part}]*"]
set all [CommandCompletion ${part}]
#puts \nmatches=$matches\n
return [Format $all $part]
} else {
# try to use $pos further ...
# puts stderr |$line|
if {"." == [string index [lindex ${line} 0] 0]} {
set alias WIDGET
} else {
set alias [lindex [QuoteQuotes ${line}] 0]
}
foreach cmd [list ${alias} tclreadline_complete_unknown] {
if {"" != [namespace eval ::tclreadline \
[list info procs complete(${cmd})]]
} {
# to be more error-proof, we check here,
# if complete($cmd) takes exactly 5 arguments.
#
if {6 != [set arguments [llength \
[namespace eval ::tclreadline \
[list info args complete(${cmd})]]]]
} {
error [list complete(${cmd}) takes ${arguments} \
arguments, but should take exactly 6.]
}
# remove leading quotes
#
if {"\"" == [string index $part 0] \
|| "\{" == [string index $part 0]
} {
set mod [string range $part 1 end]
} else {
set mod $part
}
if {[catch [list set script_result \
[complete(${cmd}) $part \
$start $end $line $pos $mod]] ::tclreadline::errorMsg]
} {
error "error during evaluation of `complete(${cmd})'"
}
return ${script_result}
}
}
# no specific command completer found.
if {"" != [array names known_cmds $cmd]} {
set current [lindex $known_cmds($cmd) $pos]
if {"" != $current && "" == [string trim $part]} {
return $current
} else {
return ""
}
} else {
return ""
}
}
error "{NOTREACHED (this is probably an error)}"
}
proc ls {args} {
if {[exec uname -s] == "Linux"} {
eval exec ls --color -FC [Glob $args]
} else {
eval exec ls -FC [Glob $args]
}
}
proc Setup {args} {
uplevel #0 {
if {"" == [info commands ::tclreadline::readline]} {
::tclreadline::Init
}
::tclreadline::readline customcompleter ::tclreadline::ScriptCompleter
if {[catch {set a [::tclreadline::prompt1]}] \
&& [info nameofexecutable] != ""} {
namespace eval ::tclreadline {
variable prompt_string
set base [file tail [info nameofexecutable]]
if {[string match tclsh* $base] && [info exists tcl_version]} {
set prompt_string \
"\[0;91mtclsh$tcl_version\[0m"
} elseif {[string match wish* $base] \
&& [info exists tk_version]} {
set prompt_string "\[0;94mwish$tk_version\[0m"
} else {
set prompt_string "\[0;91m$base\[0m"
}
}
if {"" == [info procs ::tclreadline::prompt1]} {
proc ::tclreadline::prompt1 {} {
variable prompt_string
global env
if {[catch {set pwd [pwd]} tmp]} {
set pwd "unable to get pwd"
}
if [info exists env(HOME)] {
regsub $env(HOME) $pwd "~" pwd
}
return "$prompt_string \[$pwd\]"
}
}
# puts body=[info body ::tclreadline::prompt1]
}
if {"" == [info procs exit]} {
catch {rename ::tclreadline::Exit ""}
rename exit ::tclreadline::Exit
proc exit {args} {
if {[catch {
::tclreadline::readline write \
[::tclreadline::HistoryFileGet]
} ::tclreadline::errorMsg]} {
puts stderr $::tclreadline::errorMsg
}
if [catch "eval ::tclreadline::Exit $args" message] {
puts stderr "error:"
puts stderr "$message"
}
# NOTREACHED
}
}
}
global env
variable historyfile
if {[string trim [llength ${args}]]} {
set historyfile ""
catch {
set historyfile [file nativename [lindex ${args} 0]]
}
if {"" == [string trim $historyfile]} {
set historyfile [lindex ${args} 0]
}
} else {
if [info exists env(HOME)] {
set historyfile $env(HOME)/.tclsh-history
} else {
set historyfile .tclsh-history
}
}
set ::tclreadline::errorMsg [readline initialize $historyfile]
if {$::tclreadline::errorMsg != ""} {
puts stderr $::tclreadline::errorMsg
}
InitCmds
rename Setup ""
}
proc HistoryFileGet {} {
variable historyfile
return $historyfile
}
proc Glob {string} {
set commandstring ""
foreach name $string {
set replace [glob -nocomplain -- $name]
if {$replace == ""} {
lappend commandstring $name
} else {
lappend commandstring $replace
}
}
# return $commandstring
# Christian Krone <krischan@sql.de> proposed
return [eval concat $commandstring]
}
proc Loop {args} {
eval Setup ${args}
uplevel #0 {
while {1} {
if [info exists tcl_prompt2] {
set prompt2 $tcl_prompt2
} else {
set prompt2 ">"
}
if {[catch {
if {"" != [namespace eval ::tclreadline {info procs prompt1}]} {
set LINE [::tclreadline::readline read \
[::tclreadline::prompt1]]
} else {
set LINE [::tclreadline::readline read %]
}
while {![::tclreadline::readline complete $LINE]} {
append LINE "\n"
append LINE [tclreadline::readline read ${prompt2}]
}
} ::tclreadline::errorMsg]} {
puts stderr [list tclreadline::Loop: error. \
$::tclreadline::errorMsg]
continue
}
# Magnus Eriksson <magnus.eriksson@netinsight.se> proposed
history add $LINE
if [catch {
set result [eval $LINE]
if {$result != "" && [tclreadline::Print]} {
puts $result
}
set result ""
} ::tclreadline::errorMsg] {
puts stderr $::tclreadline::errorMsg
puts stderr [list while evaluating $LINE]
}
}
}
}
proc Print {args} {
variable PRINT
if ![info exists PRINT] {
set PRINT yes
}
if [regexp -nocase \(true\|yes\|1\) $args] {
set PRINT yes
} elseif [regexp -nocase \(false\|no\|0\) $args] {
set PRINT no
}
return $PRINT
}
proc InitCmds {} {
global tcl_version tk_version
if {[info exists tcl_version]} {
InitTclCmds
}
if {[info exists tk_version]} {
InitTkCmds
}
rename InitCmds ""
}
proc InitTclCmds {} {
variable known_cmds
foreach line {
"after option ?arg arg ...?"
"append varName ?value value ...?"
"array option arrayName ?arg ...?"
"bgerror"
"binary option ?arg arg ...?"
"break"
"catch command ?varName?"
"cd"
"clock"
"close <channelId>"
"concat"
"continue"
"eof <channelId>"
"error message ?errorInfo? ?errorCode?"
"eval arg ?arg ...?"
"exec ?switches? arg ?arg ...?"
"exit ?returnCode?"
"expr arg ?arg ...?"
"fblocked <channelId>"
"fconfigure <channelId> ?optionName? ?value? ?optionName value?..."
"fcopy input output ?-size size? ?-command callback?"
"file"
"fileevent channelId event ?script?"
"flush channelId"
"for start test next command"
"foreach varList list ?varList list ...? command"
"format formatString ?arg arg ...?"
"gets channelId ?varName?"
"glob"
"global varName ?varName ...?"
"incr varName ?increment?"
"info option ?arg arg ...?"
"interp cmd ?arg ...?"
"join list ?joinString?"
"lappend varName ?value value ...?"
"lindex list index"
"linsert list <index> <element> ?element ...?"
"list"
"llength list"
"lrange list first last"
"lreplace list first last ?element element ...?"
"lsearch ?mode? list pattern"
"lsort ?options? list"
"namespace"
"package option ?arg arg ...?"
"proc name args body"
"read ?-nonewline? channelId"
"regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"
"rename oldName newName"
"scan <string> <format> ?varName varName ...?"
"set varName ?newValue?"
"split <string> ?splitChars?"
"subst ?-nobackslashes? ?-nocommands? ?-novariables? string"
"switch ?switches? string pattern body ... ?default body?"
"time <command> ?count?"
"unknown <cmdName> ?arg? ?...?"
"uplevel ?level? command ?arg ...?"
"vwait name"
"while test command"
} {
readline add $line
set known_cmds([lindex $line 0]) ${line}
}
rename InitTclCmds ""
}
proc InitTkCmds {} {
variable known_cmds
foreach line {
"bind window ?pattern? ?command?"
"bindtags window ?tags?"
"button pathName ?options?"
"canvas pathName ?options?"
"checkbutton pathName ?options?"
"clipboard option ?arg arg ...?"
"entry pathName ?options?"
"event option ?arg1?"
"font option ?arg?"
"frame pathName ?options?"
"grab option ?arg arg ...?"
"grid option arg ?arg ...?"
"image option ?args?"
"label pathName ?options?"
"listbox pathName ?options?"
"lower window ?belowThis?"
"menu pathName ?options?"
"menubutton pathName ?options?"
"message pathName ?options?"
"option cmd arg ?arg ...?"
"pack option arg ?arg ...?"
"radiobutton pathName ?options?"
"raise window ?aboveThis?"
"scale pathName ?options?"
"scrollbar pathName ?options?"
"selection option ?arg arg ...?"
"send ?options? interpName arg ?arg ...?"
"text pathName ?options?"
"tk option ?arg?"
"tkwait variable|visibility|window name"
"toplevel pathName ?options?"
"winfo option ?arg?"
"wm option window ?arg ...?"
} {
readline add $line
set known_cmds([lindex $line 0]) ${line}
}
rename InitTkCmds ""
}
# explicit command completers
#
# -------------------------------------
# TCL
# -------------------------------------
proc complete(append) {text start end line pos mod} {
if {1 == $pos} {
return [VarCompletion ${text}]
}
return ""
}
proc complete(if) {text start end line pos mod} {
# TODO: this is not good yet.
if {2 == $pos} {
return [AttemptFromList $text {then}]
} elseif {$pos > 2} {
set prev [PreviousWord ${start} ${line}]
switch $prev {
then -
else -
elseif { return "" }
}
return [AttemptFromList $text {then else elseif}]
}
}
proc complete(incr) {text start end line pos mod} {
if {1 == $pos} {
set matches [uplevel 2 info vars "${mod}*"]
set final ""
# check for integers
#
foreach match $matches {
if {[uplevel 2 array exists $match]} {
continue
}
if {[regexp {^[0-9]+$} [uplevel 2 set $match]]} {
lappend final $match
}
}
return [Format ${final} $text]
}
}
proc complete(array) {text start end line pos mod} {
if {1 == $pos} {
set cmds {
anymore donesearch exists get names
nextelement set size startsearch
}
return [AttemptFromList $text $cmds]
} elseif {2 == $pos} {
set cmd [lindex $line 1]
switch -- $cmd {
anymore -
donesearch -
exists -
get -
names -
nextelement -
set -
size -
startsearch {
set matches ""
set vars [uplevel [info level] info vars ${mod}*]
foreach var ${vars} {
if {[uplevel [info level] array exists ${var}]} {
lappend matches ${var}
}
}
return [Format ${matches} ${text}]
}
}
} elseif {3 == $pos} {
set cmd [lindex $line 1]
switch -- $cmd {
get -
names {
if {[catch {
set names [uplevel [info level] \
array names [lindex $line 2] [lindex $line 3]*]}]} {
return ""
} else {
set common [GetCommon ${names}]
if {"" == ${common}} {
return [Format ${names} ${text}]
} else {
return [string trim "${common} ${names}"]
}
}
}
}
}
return ""
}
proc complete(binary) {text start end line pos mod} {
if {1 == $pos} {
set cmds {
format scan
}
return [AttemptFromList $text $cmds]
#
# } elseif {2 == $pos} {
# set cmd [lindex $line 1]
# switch -- $cmd {
# format -
# scan -
# }
#
}
return ""
}
proc complete(clock) {text start end line pos mod} {
if {1 == $pos} {
set cmds {clicks format scan seconds}
return [AttemptFromList $text $cmds]
} elseif {2 == $pos} {
set cmd [lindex $line 1]
switch -- $cmd {
clicks {}
format {
if {"" == [lindex $line 2]} {
return <clockValue>
}
}
scan {
if {"" == [lindex $line 2]} {
return <dateString>
}
}
seconds {}
}
} elseif {3 == $pos} {
set cmd [lindex $line 1]
switch -- $cmd {
clicks {}
format {
set sub [lindex $line 3]
set subcmds {-fmt -gmt}
return [AttemptFromList $text $subcmds]
}
scan {
set sub [lindex $line 3]
set subcmds {-base -gmt}
return [AttemptFromList $text $subcmds]
}
seconds {}
}
}
return ""
}
proc complete(encoding) {text start end line pos mod} {
if {1 == $pos} {
set cmds {convertfrom convertto names system}
return [AttemptFromList $text $cmds]
} elseif {2 == $pos} {
set cmd [lindex $line 1]
switch -- $cmd {
names {}
convertfrom -
convertto -
system {
set enc [encoding names]
return [AttemptFromList ${text} ${enc}]
}
}
}
return ""
}
proc complete(expr) {text start end line pos mod} {
set cmds {
acos cos hypot sinh
asin cosh log sqrt
atan exp log10 tan
atan2 floor pow tanh
ceil fmod sin abs
double int rand round
srand
}
return [AttemptFromList $text $cmds]
}
proc complete(fconfigure) {text start end line pos mod} {
if {1 == $pos} {
return [ChannelId ${mod}]
} else {
set option [PreviousWord ${start} ${line}]
switch -- $option {
-blocking {
return [AttemptFromList ${text} {yes no}]
}
-buffering {
return [AttemptFromList ${text} {full line none}]
}
-buffersize {
if {![llength ${text}} {
return <newSize>
}
}
-encoding {
set enc [encoding names]
return [AttemptFromList ${text} ${enc}]
}
-eofchar {
if {![llength ${text}]} {
return [list {{<inChar> <outChar>}}]
}
}
-translation {
return [AttemptFromList ${text} {auto binary cr crlf lf}]
}
}
set cmds {
-blocking
-buffering
-buffersize
-encoding
-eofchar
-translation
}
return [AttemptFromList $text $cmds]
}
return ""
}
proc complete(fcopy) {text start end line pos mod} {
if {1 == $pos} {
return [InChannelId ${mod}]
} elseif {2 == $pos} {
return [OutChannelId ${mod}]
} else {
set option [PreviousWord ${start} ${line}]
switch -- $option {
-size {
if {![llength ${mod}]} { return <size> }
}
-command {
if {![llength ${mod}]} { return <callback> }
}
}
return [AttemptFromList $text {-size -command}]
}
return ""
}
proc complete(file) {text start end line pos mod} {
if {1 == $pos} {
set cmds {
atime attributes copy delete dirname executable exists
extension isdirectory isfile join lstat mtime mkdir
nativename owned pathtype readable readlink rename
rootname size split stat tail type volumes writable
}
return [AttemptFromList $text $cmds]
} elseif {2 == $pos} {
set cmd [lindex $line 1]
switch -- $cmd {
atime -
attributes -
dirname -
executable -
exists -
extension -
isdirectory -
isfile -
join -
lstat -
mtime -
mkdir -
nativename -
owned -
pathtype -
readable -
readlink -
rootname -
size -
split -
stat -
tail -
type -
volumes -
writable {
return ""
}
copy -
delete -
rename {
set match [AttemptFromList ${mod} {-force}]
if {[llength ${match}] && [llength ${mod}]} {
return ${match}
} else {
return ""
}
}
}
}
}
proc complete(fileevent) {text start end line pos mod} {
if {1 == $pos} {
return [ChannelId ${mod}]
} elseif {2 == $pos} {
return [AttemptFromList ${mod} {readable writable}]
}
}
proc complete(flush) {text start end line pos mod} {
if {1 == $pos} {
return [ChannelId ${mod}]
}
}
proc complete(gets) {text start end line pos mod} {
if {1 == $pos} {
return [InChannelId ${mod}]
}
}
proc complete(glob) {text start end line pos mod} {
if {1 == $pos} {
set matches [AttemptFromList ${mod} {-nocomplain --}]
if {[llength [string trim ${mod}]] && [llength ${matches}]} {
return ${matches}
}
}
return ""
}
proc complete(global) {text start end line pos mod} {
return [VarCompletion ${text}]
}
proc complete(index) {text start end line pos mod} {
if {1 == $pos} {
return [VarCompletion ${text}]
} elseif {2 == $pos && ![llength ${mod}]} {
return <index>
}
return ""
}
proc complete(info) {text start end line pos mod} {
if {1 == $pos} {
set cmds {
args body cmdcount commands complete default exists
globals hostname level library loaded locals nameofexecutable
patchlevel procs script sharedlibextension tclversion vars}
return [AttemptFromList $text $cmds]
} elseif {2 == $pos} {
set cmd [lindex $line 1]
switch -- $cmd {
args -
body -
default -
procs { return [complete(proc) ${text} 0 0 ${line} 1 ${mod}] }
complete { ; # TODO
}
level { ; # TODO
}
loaded { ;# TODO
}
commands -
exists -
globals -
locals -
vars {
if {"exists" == $cmd} {
set do vars
} else {
set do $cmd
}
# puts stderr [list complete(info) level = [info level]]
return \
[Format [uplevel 2 info ${do} "${mod}*"] $text]
}
}
}
return ""
}
proc complete(interp) {text start end line pos mod} {
set cmd [lindex $line 1]
if {1 == $pos} {
set cmds {
alias aliases create delete eval exists expose hide hidden
issafe invokehidden marktrusted slaves share target transfer}
return [AttemptFromList $text $cmds]
} elseif {2 == $pos} {
switch -- $cmd {
create {
return [AttemptFromList $text {-safe -- ?path?}]
}
eval -
exists -
expose -
hide -
hidden -
invokehidden -
marktrusted -
target {if {![llength ${mod}]} { return <path> }}
aliases -
delete -
issafe -
slaves {if {![llength ${mod}]} { return ?path? }}
alias -
share -
transfer {if {![llength ${mod}]} { return <srcPath> }}
}
} elseif {3 == $pos} {
switch -- $cmd {
alias {if {![llength ${mod}]} { return <srcCmd> }}
create {
return [AttemptFromList $text {-safe -- ?path?}]
}
eval {if {![llength ${mod}]} { return <arg> }}
delete {if {![llength ${mod}]} { return ?path? }}
expose {if {![llength ${mod}]} { return <hiddenName> }}
hide {if {![llength ${mod}]} { return <exposedCmdName> }}
invokehidden {
return \
[AttemptFromList $text {?-global? <hiddenCmdName}]
}
target {if {![llength ${mod}]} { return <alias> }}
exists {}
hidden {}
marktrusted {}
aliases {}
issafe {}
slaves {}
share -
tranfer {return [ChannelId ${mod}]}
}
} elseif {4 == $pos} {
switch -- $cmd {
alias {if {![llength ${mod}]} { return <targetPath> }}
create {
return [AttemptFromList $text {-safe -- path}]
}
expose {if {![llength ${mod}]} { return ?exposedCmdName? }}
hide {if {![llength ${mod}]} { return ?hiddenCmdName? }}
share -
tranfer {if {![llength ${mod}]} { return ?destPath? }}
}
}
return ""
}
proc complete(join) {text start end line pos mod} {
if {1 == $pos} {
return [VarCompletion ${text}]
}
return ""
}
proc complete(lappend) {text start end line pos mod} {
if {1 == $pos} {
return [ListCompletion ${text}]
}
return ""
}
proc complete(linsert) {text start end line pos mod} {
if {1 == $pos} {
return [ListCompletion ${text}]
}
return ""
}
proc complete(llength) {text start end line pos mod} {
if {1 == $pos} {
return [ListCompletion ${text}]
}
return ""
}
proc complete(load) {text start end line pos mod} {
if {1 == $pos} {
return ""; # filename
} elseif {2 == $pos && ![llength ${mod}]} {
return "<packageName>"
} elseif {3 == $pos && ![llength ${mod}]} {
return "<interp>"
}
return ""
}
proc complete(lrange) {text start end line pos mod} {
if {1 == $pos} {
return [ListCompletion ${text}]
} elseif {2 == $pos && ![llength ${mod}]} {
return "<first>"
} elseif {3 == $pos && ![llength ${mod}]} {
return "<last>"
}
return ""
}
proc complete(lreplace) {text start end line pos mod} {
if {1 == $pos} {
return [ListCompletion ${text}]
} elseif {2 == $pos && ![llength ${mod}]} {
return "<first>"
} elseif {3 == $pos && ![llength ${mod}]} {
return "<last>"
} elseif {![llength ${mod}]} {
return "?element?"
}
return ""
}
proc complete(lsearch) {text start end line pos mod} {
if {1 == $pos} {
set options [MenuFromList ${mod} {
-exact -glob -regexp <list>}]
set matches [ListCompletion ${text}]
return [string trim "${matches} ${options}"]
} else {
if {![llength ${mod}]} {
set opt [lindex ${line} 1]
if {[llength [MenuFromList ${opt} {
-exact -glob -regexp }]]} {
incr pos -1
}
if {1 == $pos} {
return <list>
} elseif {2 == $pos} {
return <pattern>
}
}
}
return ""
}
proc complete(lsort) {text start end line pos mod} {
set options [Menu ${mod} {
-ascii -dictionary -integer -real -command
-increasing -decreasing -index
}]
set matches [ListCompletion ${text}]
return [string trim "${matches} ${options}"]
}
proc complete(history) {text start end line pos mod} {
if {1 == $pos} {
set cmds {add change clear event info keep nextid redo}
return [AttemptFromList $text $cmds]
} elseif {2 == ${pos}} {
set cmd [lindex $line 1]
switch -- $cmd {
add { if {![llength ${mod}]} { return <newValue> } }
change { if {![llength ${mod}]} { return <newValue> } }
info -
keep { if {![llength ${mod}]} { return ?count? } }
event -
redo { if {![llength ${mod}]} { return ?event? } }
clear -
nextid { return "" }
}
}
return ""
}
proc complete(namespace) {text start end line pos mod} {
regsub {^([^:])} ${mod} {::\1} mod
# TODO dosn't work ???
set space_matches [namespace children :: [string trim ${mod}*]]
# puts \nspace_matches=|${space_matches}|
set cmd [lindex $line 1]
if {1 == $pos} {
set cmds {
children code current delete eval export forget
import inscope origin parent qualifiers tail which}
return [AttemptFromList $text $cmds]
} elseif {2 == $pos} {
switch -- $cmd {
children -
delete -
eval -
inscope -
forget -
parent { return [AttemptFromList ${mod} $space_matches] }
code { return "" }
current {}
export { return [MenuFromList ${mod} -clear ?pattern?] }
import {
return [MenuFromList ${mod} "-force $space_matches"]
}
origin { if {![llength ${mod}]} { return <command> } }
qualifiers -
tail { if {![llength ${mod}]} { return <string> } }
which { return [MenuFromList ${mod} {
-command -variable <name>}] }
}
# forget { if {![llength ${mod}]} { return ?pattern? } }
} elseif {3 == $pos && "inscope" == $cmd} {
if {![llength ${mod}]} { return arg }
} else {
switch -- $cmd {
children { if {![llength ${mod}]} { return ?pattern? } }
delete { return [AttemptFromList $text $space_matches] }
eval { if {![llength ${mod}]} { return ?arg? } }
inscope { if {![llength ${mod}]} { return ?arg? } }
parent {}
code {}
current {}
export -
forget -
import { return [Menu ?pattern?] }
origin {}
qualifiers {}
tail {}
which { return [MenuFromList $text {
-command -variable <name>}] }
}
}
return ""
}
proc complete(open) {text start end line pos mod} {
if {![llength ${mod}]} {
if {2 == $pos} {
return ?access?
} elseif {3 == $pos} {
return ?permissions?
}
}
return ""
}
proc complete(package) {text start end line pos mod} {
set cmd [lindex $line 1]
if {1 == $pos} {
set cmds {
forget ifneeded names present provide require
unknown vcompare versions vsatisfies}
return [AttemptFromList $text $cmds]
} elseif {2 == $pos} {
switch -- $cmd {
forget -
ifneeded -
provide -
versions { return [MenuFromList ${mod} [package names]] }
present -
require {
return [MenuFromList ${mod} "-exact [package names]"] }
names {}
unknown { if {![llength ${mod}]} { return ?command? } }
vcompare -
vsatisfies { if {![llength ${mod}]} { return <version1> } }
}
} elseif {3 == $pos} {
switch -- $cmd {
forget {}
ifneeded { if {![llength ${mod}]} { return <version> } }
provide { if {![llength ${mod}]} { return ?version? } }
versions {}
present -
require {
set prev [PreviousWord ${start} ${line}]
if {[llength [MenuFromList ${prev} -exact]]} {
return [MenuFromList ${mod} [package names]]
} elseif {![llength ${mod}]} {
return ?version?
}
}
names {}
unknown {}
vcompare -
vsatisfies { if {![llength ${mod}]} { return <version2> } }
}
}
return ""
}
proc complete(pkg_mkIndex) {text start end line pos mod} {
set cmds [RemoveUsedOptions ${line} {-direct -load -verbose -- <dir>} {--}]
set res [string trim [MenuFromList $text $cmds]]
if {[regexp -- [PreviousWord ${start} ${line}] -load] \
&& ![llength ${mod}]} {
return <pkgPat>
}
if {![llength [join ${res}]]} {
return ""
} else {
return ${res}
}
return ""
}
proc complete(proc) {text start end line pos mod} {
# puts known_procs=|${known_procs}|
if {1 == $pos} {
set known_procs [ProcsOnlyCompletion ${mod}]
set common [GetCommon ${known_procs}]
if {"" == ${common}} {
return [Format ${known_procs} ${text}]
} else {
return [string trim "${common} ${known_procs}"]
}
} elseif {2 == $pos} {
set proc [lindex $line 1]
if {[catch {set args [uplevel 2 info args ${proc}]}]} {
return ""
} else {
return [list "\{${args}\} \{"]
}
}
return ""
}
proc complete(puts) {text start end line pos mod} {
if {1 == $pos} {
return [MenuFromList ${mod} "-nonewline [OutChannelId ${mod}]"]
} elseif {2 <= $pos} {
if {![llength ${mod}]} {
set opt [lindex ${line} 1]
if {[llength [MenuFromList ${opt} {-nonewline}]]} {
incr pos -1
}
if {1 == $pos} {
return [OutChannelId ${mod}]
} elseif {2 == $pos} {
return [Menu <string>]
return <string>
}
}
}
return ""
}
proc complete(read) {text start end line pos mod} {
if {1 == $pos} {
return [MenuFromList ${mod} "-nonewline [InChannelId ${mod}]"]
} elseif {2 == $pos} {
if {![llength ${mod}]} {
set opt [lindex ${line} 1]
if {[llength [MenuFromList ${opt} {-nonewline}]]} {
return [InChannelId ${mod}]
} elseif {![llength ${mod}]} {
return <numBytes>
}
}
}
return ""
}
proc complete(regexp) {text start end line pos mod} {
set prev [PreviousWord ${start} ${line}]
if {[llength ${prev}] && ("-" == [string index ${prev} 0] || 1 == $pos)} {
set cmds [RemoveUsedOptions ${line} {
-nocase -indices -expanded -line
-linestop -lineanchor -about <expression> --} {--}]
if {[llength ${cmds}]} {
return [string trim [MenuFromList $text $cmds]]
}
} else {
set virtual_pos [expr ${pos} - [FirstNonOption ${line}]]
switch -- ${virtual_pos} {
1 { if {![llength ${mod}]} { return <string> } }
2 { if {![llength ${mod}]} { return ?matchVar? } }
default { if {![llength ${mod}]} { return ?subMatchVar? } }
}
}
return ""
}
proc complete(regsub) {text start end line pos mod} {
set prev [PreviousWord ${start} ${line}]
if {[llength ${prev}] && ("-" == [string index ${prev} 0] || 1 == $pos)} {
set cmds [RemoveUsedOptions ${line} {-all -nocase -- <expression>} {--}]
set res [string trim [MenuFromList ${mod} ${cmds}]]
if {[llength ${res}]} {
return ${res}
}
} else {
set virtual_pos [expr ${pos} - [FirstNonOption ${line}]]
switch -- ${virtual_pos} {
1 { if {![llength ${mod}]} { return <expression> } }
2 { if {![llength ${mod}]} { return <string> } }
3 { if {![llength ${mod}]} { return <subSpec> } }
4 { if {![llength ${mod}]} { return <varName> } }
}
}
return ""
}
proc complete(rename) {text start end line pos mod} {
if {1 == $pos} {
set all [CommandCompletion ${mod}]
return [Format $all ${mod}]
} elseif {2 == $pos && ![llength ${mod}]} {
return <newName>
}
return ""
}
proc complete(return) {text start end line pos mod} {
# TODO this is not perfect yet
set cmds {-code -errorinfo -errorcode <string>}
set res [MenuFromList [PreviousWord ${start} ${line}] ${cmds}]
if {1 == [llength ${res}]} {
switch -- ${res} {
-errorinfo { if {![llength ${mod}]} { return <info> } }
-code -
-errorcode {
set codes {ok error return break continue}
return [AttemptFromList ${mod} ${codes}]
}
}
}
set cmds [RemoveUsedOptions ${line} ${cmds}]
set res [string trim [MenuFromList ${mod} ${cmds}]]
if {[llength ${res}]} {
return ${res}
}
return ""
}
proc complete(seek) {text start end line pos mod} {
if {1 == $pos} {
return [ChannelId ${mod}]
} elseif {2 == $pos} {
return [AttemptFromList ${mod} {start current end}]
}
return ""
}
proc complete(set) {text start end line pos mod} {
# puts stderr "\ntext=|$text| $start $end\n"
# puts stderr \nline=|$line|\n
# puts stderr \npos=|$pos|\n
# puts stderr \nmod=|$mod|\n
if {1 == $pos} {
return [VarCompletion ${text}]
} elseif {2 == $pos && ($text == "" || $text == "\"" || $text == "\{")} {
set line [QuoteQuotes $line]
if {[catch "set value [list [uplevel [info level] set [lindex $line 1]]]" msg]} {
return ""
} else {
return [Quote $value ${text}]
}
}
return ""
}
proc complete(socket) {text start end line pos mod} {
set cmd [lindex ${line} 1]
set prev [PreviousWord ${start} ${line}]
if {"-server" == ${cmd}} {
# server sockets
#
if {2 == $pos && ![llength ${mod}]} { return <command> }
switch -- ${prev} {
-myaddr { if {![llength ${mod}]} { return <addr> } }
}
return [AttemptFromList ${mod} [concat {-error -sockname -peername}]]
} else {
# client sockets
#
switch -- ${prev} {
-myaddr { if {![llength ${mod}]} { return <addr> } }
-myport { if {![llength ${mod}]} { return <port> } }
}
# read the host table only once.
#
variable hosts
if {![info exists hosts] && "-server" != ${cmd}} {
set id [open /etc/hosts r]
set hosts ""
if {0 != ${id}} {
while {-1 != [gets ${id} line]} {
regsub {#.*} ${line} {} line
if {[llength ${line}] >= 2} {
lappend hosts [lindex ${line} 1]
}
}
close $id
}
}
set cmds {-myaddr -myport -async -myaddr -error -sockname -peername}
if {$pos <= 1} {
lappend cmds -server
}
return [AttemptFromList ${mod} [concat ${cmds} ${hosts}]]
}
return ""
}
proc complete(source) {text start end line pos mod} {
return ""; # force file name completion
}
proc complete(string) {text start end line pos mod} {
set cmd [lindex ${line} 1]
set cmds {
compare first index last length match range tolower
totitle toupper trim trimleft trimright wordend wordstart}
if {1 == $pos} {
return [AttemptFromList ${mod} ${cmds}]
} elseif {2 == $pos} {
switch -- $cmd {
compare -
first -
last { if {![llength ${mod}]} { return <string1> } }
match { if {![llength ${mod}]} { return <pattern> } }
index -
length -
range -
tolower -
totitle -
toupper -
trim -
trimleft -
trimright -
wordend -
wordstart { if {![llength ${mod}]} { return <string> } }
}
} elseif {3 == $pos} {
switch -- $cmd {
compare -
first -
last { if {![llength ${mod}]} { return <string2> } }
index { if {![llength ${mod}]} { return <charIndex> } }
length {}
match { if {![llength ${mod}]} { return <string> } }
range { if {![llength ${mod}]} { return <first> } }
tolower -
totitle -
toupper {}
trim -
trimleft { if {![llength ${mod}]} { return ?chars? } }
trimright -
wordend -
wordstart { if {![llength ${mod}]} { return <index> } }
}
}
return ""
}
proc complete(subst) {text start end line pos mod} {
set opts {-nobackslashes -nocommands -novariables}
set opts [RemoveUsedOptions ${line} ${opts}]
return [AttemptFromList ${mod} [concat ${opts} <string>]]
return ""
}
proc complete(switch) {text start end line pos mod} {
set opts {-exact -glob -regexp --}
set opts [RemoveUsedOptions ${line} ${opts} {--}]
return [AttemptFromList ${mod} [concat ${opts} <string>]]
return ""
}
proc complete(tell) {text start end line pos mod} {
if {1 == $pos} {
return [ChannelId ${mod}]
}
return ""
}
proc complete(trace) {text start end line pos mod} {
set cmd [lindex ${line} 1]
if {1 == $pos} {
return [AttemptFromList ${mod} {variable vdelete vinfo}]
} elseif {2 == $pos} {
return [Format [uplevel 2 info vars "${mod}*"] ${mod}]
} elseif {3 == $pos && "variable" == ${cmd}} {
return [AttemptFromList ${mod} {r w u}]
}
return ""
}
proc complete(update) {text start end line pos mod} {
if {1 == $pos && ![llength ${mod}]} {
return idletasks
}
return ""
}
proc complete(uplevel) {text start end line pos mod} {
if {![llength ${mod}]} {
if {1 == $pos} {
return ?level?
} elseif {2 == $pos} {
return <command>
} elseif {3 == $pos} {
return ?arg?
} elseif {4 == $pos} {
return ?...?
}
}
return ""
}
proc complete(upvar) {text start end line pos mod} {
if {![llength ${mod}]} {
if {1 == $pos} {
return ?level?
} elseif {2 == $pos} {
return <otherVar>
} elseif {3 == $pos} {
return <myVar>
} elseif {4 == $pos} {
return ?...?
}
}
return ""
}
proc complete(variable) {text start end line pos mod} {
set modulo [expr $pos % 2]
if {1 == ${modulo}} {
return [VarCompletion ${mod}]
} elseif {0 == ${modulo} && \
($text == "" || $text == "\"" || $text == "\{")} {
set line [QuoteQuotes $line]
incr pos -1
if {[catch \
"set value [list [uplevel [info level] set [lindex $line ${pos}]]]"\
msg]} {
return ""
} else {
return [Quote $value ${mod}]
}
}
return ""
}
proc complete(vwait) {text start end line pos mod} {
if {1 == ${pos}} {
return [VarCompletion ${mod}]
}
}
proc complete(unset) {text start end line pos mod} {
return [VarCompletion ${text}]
}
# -------------------------------------
# TK
# -------------------------------------
# generic widget configuration
proc TrySubCmds {cmd} {
set trystring ____
set result ""
if [catch {set result [${cmd} ${trystring}]} msg] {
if {[regexp {bad *option.*____.*: *must *be( .*$)} ${msg} all raw]} {
regsub -all -- , ${raw} { } raw
set len [llength ${raw}]
set len_2 [expr ${len} - 2]
for {set i 0} {${i} < ${len}} {incr i} {
set word [lindex ${raw} ${i}]
if {"or" != ${word} && ${i} != ${len_2}} {
lappend result ${word}
}
}
} else {
# check, if it's a blt error msg ...
#
set msglst [split ${msg} \n]
foreach line ${msglst} {
if {[regexp "${cmd}\[ \t\]\+\(\[^ \t\]*\)\[^:\]*$" \
${line} all sub]} {
lappend result [list ${sub}]
}
}
}
}
return ${result}
}
proc WidgetList {pattern} {
regsub {^([^\.])} ${pattern} {\.\1} pattern
if {[winfo exists ${pattern}]} {
return [winfo children ${pattern}]
} else {
regsub {.[^.]*$} $pattern {} pattern
if {[winfo exists ${pattern}]} {
return [winfo children ${pattern}]
} else {
return ""
}
}
}
proc complete(WIDGET) {text start end line pos mod} {
set widget [lindex ${line} 0]
set cmd [lindex ${line} 1]
# first we build an option table
#
if {[catch [list set option_table [${widget} configure]] msg]} {
return ""
}
foreach optline ${option_table} {
if {5 != [llength ${optline}]} continue else {
lappend options(switches) [lindex ${optline} 0]
lappend options(value) [lindex ${optline} 4]
}
}
if {1 >= ${pos}} {
set cmds [TrySubCmds ${widget}]
if {[llength ${cmds}]} {
return [AttemptFromList ${mod} ${cmds}]
}
} elseif {2 <= ${pos} &&
([string match ${cmd}* cget] || \
[string match ${cmd}* configure])} {
set prev [PreviousWord ${start} ${line}]
#puts \nprev=|$prev|
#puts switches=|$options(switches)|
#puts found=[lsearch -exact ${prev} $options(switches)]
if {-1 != [set found [lsearch -exact $options(switches) ${prev}]]} {
if {![llength ${mod}]} {
return [list "[lindex $options(value) ${found}]"]
}
} else {
return [AttemptFromList ${mod} $options(switches)]
}
}
return ""
}
proc complete(winfo) {text start end line pos mod} {
set cmd [lindex ${line} 1]
if {1 >= ${pos}} {
set cmds [TrySubCmds winfo]
if {[llength ${cmds}]} {
return [AttemptFromList ${mod} ${cmds}]
}
} elseif {2 == ${pos}} {
return [AttemptFromList ${mod} [WidgetList ${mod}]]
}
return ""
}
}; # namespace tclreadline