#!/usr/locanl/bin/tclsh # FILE: "/home/joze/src/tclreadline/tclreadlineCompleter.tcl" # LAST MODIFICATION: "Mon Sep 13 02:21:21 1999 (joze)" # (C) 1998, 1999 by Johannes Zellner, # $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/ # # ================================================================== # TODO: # # - tcltest is missing # # - last try: as for widgets # namespace eval tclreadline { namespace export \ TryFromList CompleteFromList DisplayHints Rehash \ PreviousWord CommandCompletion RemoveUsedOptions \ HostList ChannelId InChannelId OutChannelId \ Lindex Llength CompleteBoolean #** # TryFromList 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 TryFromList {text lst {allow ""}} { # puts stderr "(CompleteFromList) \ntext=|$text|" # puts stderr "(CompleteFromList) lst=|$lst|" set pre [GetQuotedPrefix ${text}] set matches [MatchesFromList $text $lst $allow] # puts stderr "(CompleteFromList) matches=|$matches|" if {1 == [llength $matches]} { ; # unique match # puts stderr \nunique=$matches\n # puts stderr "\n|${pre}${matches}[Right ${pre}]|\n" set null [string index $matches 0] if {"<" == $null || "?" == $null} { return [string trim "[list $text] $lst"] } else { return [string trim ${pre}${matches}[Right ${pre}]] } } elseif {"" != ${matches}} { # puts stderr \nmore=$matches\n set longest [CompleteLongest ${matches}] # puts stderr longest=|$longest| if {"" == $longest} { return [string trim "[list $text] ${matches}"] } else { return [string trim "${pre}${longest} ${matches}"] } } else { return ""; # nothing to complete } } #** # CompleteFromList will never return an empty string. # completes, if a completion can be done, or ring # the bell if not. # proc CompleteFromList {text lst} { set result [TryFromList ${text} ${lst}] if {![llength ${result}]} { Alert # return [string trim [list ${text}] ${lst}"] if {[llength ${lst}]} { return [string trim "${text} ${lst}"] } else { return [string trim [list ${text} {}]] } } else { return ${result} } } #** # CompleteBoolean does a CompleteFromList # with a list of all valid boolean values. # proc CompleteBoolean {text} { return [CompleteFromList $text {yes no true false 1 0}] } #** # build a list of all executables which can be # found in $env(PATH). This is (naturally) a bit # slow, and should not called frequently. Instead # it is a good idea to check if the variable # `executables' exists and then just use it's # content instead of calling Rehash. # (see complete(exec)). # proc Rehash {} { global env variable executables if {![info exists env] || ![array exists env]} { return } if {![info exists env(PATH)]} { return } set executables 0 foreach dir [split $env(PATH) :] { if {[catch [list set files [glob -nocomplain ${dir}/*]]]} { continue } foreach file $files { if {[file executable $file]} { lappend executables [file tail $file] } } } } #** # build a list hosts from the /etc/hosts file. # this is only done once. This is sort of a # dirty hack, /etc/hosts is hardcoded ... # proc HostList {} { # read the host table only once. # variable hosts if {![info exists hosts]} { catch { 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 } } } return $hosts } #** # never return an empty string, never complete. # This is useful for showing options lists for example. # proc DisplayHints {lst} { return [string trim "{} ${lst}"] } #** # find (partial) matches for `text' in `lst'. Ring # the bell and return the whole list, if the user # tries to complete ?..? options or <..> hints. # # MatchesFromList returns a list which is not suitable # for passing to the readline completer. Thus, # MatchesFromList should not be called directly but # from formatting routines as TryFromList. # proc MatchesFromList {text lst {allow ""}} { set result "" set text [StripPrefix $text] set null [string index $text 0] foreach char {< ?} { if {$char == $null && -1 == [string first $char $allow]} { Alert return $lst } } # puts stderr "(MatchesFromList) text=$text" # puts stderr "(MatchesFromList) lst=$lst" foreach word $lst { if {[string match ${text}* ${word}]} { lappend result ${word} } } return [string trim $result] } 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 "" # return ${terminate} } } set new "" foreach word ${opts} { if {-1 == [string first ${word} ${line}]} { lappend new ${word} } } return [string trim ${new}] } proc Alert {} { puts -nonewline \a flush stdout } #** # get the longest common completion # e.g. str == {tcl_version tclreadline_version tclreadline_library} # --> [CompleteLongest ${str}] == "tcl" # proc CompleteLongest {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 SplitLine {start line} { set depth 0 # puts stderr SplitLine 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}] } } # the following two channel proc's make use of # the brandnew (Sep 99) `file channels' command # but have some fallback behaviour for older # tcl version. # proc InChannelId {text {switches ""}} { if [catch {set chs [file channels]}] { set chs {stdin} } set result "" foreach ch $chs { if {![catch {fileevent $ch readable}]} { lappend result $ch } } return [ChannelId ${text} $result $switches] } proc OutChannelId {text {switches ""}} { if [catch {set chs [file channels]}] { set chs {stdout stderr} } set result "" foreach ch $chs { if {![catch {fileevent $ch writable}]} { lappend result $ch } } return [ChannelId ${text} $result $switches] } proc ChannelId {text {descript } {chs ""} {switches ""}} { if {"" == ${chs}} { # the `file channels' command is present # only in pretty new versions. # if [catch {set chs [file channels]}] { set chs {stdin stdout stderr} } } if {[llength [set channel [TryFromList ${text} "${chs} ${switches}"]]]} { return ${channel} } else { return [DisplayHints [string trim "${descript} ${switches}"]] } } proc QuoteQuotes {line} { regsub -all -- \" $line {\"} line regsub -all -- \{ $line {\{} line; # \}\} (keep the editor happy) return $line } proc Trace {varT} { if {![info exists ::tclreadline::Debug]} {return} upvar $varT var if {![info exists var]} { puts $varT= } else { puts $varT=|$var| } # puts $var } #** # get the word position. # @return the word position # @note will returned modified values. # @sa EventuallyEvaluateFirst # @date Sep-06-1999 # # % p # % bla put $b # % put $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 return [Llength [string range $line 0 [expr $start - 1]]] # # set local_start [expr $start - 1] # set local_start_chr [string index $line $local_start] # if {"\"" == $local_start_chr || "\{" == $local_start_chr} { # incr local_start -1 # } # # set pre_text [QuoteQuotes [string range $line 0 $local_start]] # return [llength $pre_text] # } proc Right {left} { # puts left=$left if {"\"" == $left} { return "\"" } elseif {"\\\"" == $left} { return "\\\"" } elseif {"\{" == $left} { return "\}" } elseif {"\\\{" == $left} { return "\\\}" } return "" } proc GetQuotedPrefix {text} { set null [string index $text 0] if {"\"" == $null || "\{" == $null} { return \\$null } else { return {} } } proc CountChar {line char} { # puts stderr char=|$char| set found 0 set pos 0 while {-1 != [set pos [string first $char $line $pos]]} { incr pos incr found } return $found } #** # make a proper tcl list from an icomplete # string, that is: remove the junk. This is # complementary to `IncompleteListRemainder'. # e.g.: # for {set i 1} " # --> for {set i 1} # proc ProperList {line} { set last [expr [string length $line] - 1] for {set i $last} {$i >= 0} {incr i -1} { if {![catch {llength [string range $line 0 $i]}]} { break } } return [string range $line 0 $i] } #** # return the last part of a line which # prevents the line from beeing a list. # This is complementary to `ProperList'. # proc IncompleteListRemainder {line} { set last [expr [string length $line] - 1] for {set i $last} {$i >= 0} {incr i -1} { if {![catch {llength [string range $line 0 $i]}]} { break } } incr i return [string range $line $i end] } #** # save `lindex'. works also for non-complete lines # with opening parentheses or quotes. # usage as `lindex'. # Eventually returns the Rest of an incomplete line, # if the index is `end' or == [Llength $line]. # proc Lindex {line pos} { if {[catch [list set sub [lindex $line $pos]]]} { if {"end" == $pos || [Llength $line] == $pos} { return [IncompleteListRemainder $line] } set line [ProperList $line] # puts stderr \nproper_line=|$proper_line| if {[catch [list set sub [lindex $line $pos]]]} { return {} } } return $sub } #** # save `llength' (see above). # proc Llength {line} { if {[catch [list set len [llength $line]]]} { set line [ProperList $line] if {[catch [list set len [llength $line]]]} { return {} } } # puts stderr \nline=$line return $len } proc StripPrefix {text} { # puts "(StripPrefix) text=|$text|" set null [string index $text 0] if {"\"" == $null || "\{" == $null} { return [string range $text 1 end] } else { return $text } } proc VarCompletion {text {level -1}} { if {-1 == ${level}} { set level [info level] } else { incr level } set pre [GetQuotedPrefix ${text}] set var [StripPrefix ${text}] # puts stderr "(VarCompletion) pre=|$pre|" # puts stderr "(VarCompletion) var=|$var|" # 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}([CompleteLongest ${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 return [CompleteFromList ${text} ${matches}] } else { return ""; # nothing to complete } } proc CompleteControlStatement {text start end line pos mod pre new_line} { set pre [GetQuotedPrefix ${pre}] set cmd [Lindex $new_line 0] set diff [expr \ [string length $line] - [string length $new_line]] if {$diff == [expr $start + 1]} { set mod1 $mod } else { set mod1 $text set pre "" } set new_end [expr $end - $diff] set new_start [expr $new_end - [string length $mod1]] # puts "" # puts new_start=$new_start # puts new_end=$new_end # puts new_line=$new_line # puts mod1=$mod1 if {$new_start < 0} { return ""; # when does this occur? } # puts stderr "" # puts stderr start=|$start| # puts stderr end=|$end| # puts stderr mod=|$mod| # puts stderr new_start=|$new_start| # puts stderr new_end=|$new_end| # puts stderr new_line=|$new_line| # puts stderr "" set res [ScriptCompleter $mod1 $new_start $new_end $new_line] # puts stderr \n\${pre}\${res}=|${pre}${res}| if {[string length [Lindex ${res} 0]]} { return ${pre}${res} } else { return ${res} } return "" } proc BraceOrControlStatement {text start end line pos mod} { if {![string length [Lindex $line $pos]]} { return [list \{ {}]; # \} } else { set new_line [string trim [IncompleteListRemainder $line]] if {![regexp {^([\{\"])(.*)$} $new_line all pre new_line]} { set pre "" } return [CompleteControlStatement $text \ $start $end $line $pos $mod $pre $new_line] } } proc FullQualifiedMatches {qualifier matchlist} { set new "" if {"" != $qualifier && ![regexp ::$ $qualifier]} { append qualifier :: } 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 ::} {pre UNDEFINED}} { # puts stderr "(CommandCompletion) cmd=|$cmd|" # puts stderr "(CommandCompletion) action=|$action|" # puts stderr "(CommandCompletion) spc=|$spc|" # get the leading colons in `cmd'. if {"UNDEFINED" == $pre} { regexp {^:*} ${cmd} pre } # puts stderr \npre=|$pre| set cmd [StripPrefix ${cmd}] set quali [namespace qualifiers ${cmd}] if {[string length ${quali}]} { # puts stderr \nquali=|$quali| set matches [CommandCompletion \ [namespace tail ${cmd}] ${action} ${spc}${quali} ${pre}] # puts stderr \nmatches1=|$matches| return $matches } set cmd [string trim ${cmd}]* # puts stderr \ncmd=|$cmd|\n if {"procs" != ${action}} { set all_commands [namespace eval $spc [list info commands ${cmd}]] # puts stderr all_commands=|$all_commands| set commands "" foreach command $all_commands { if {[namespace eval $spc [list namespace origin $command]] == \ [namespace eval $spc [list namespace which $command]]} { lappend commands $command } } } else { set commands "" } if {"commands" != ${action}} { set all_procs [namespace eval $spc [list info procs ${cmd}]] # puts stderr procs=|$procs| set procs "" foreach proc $all_procs { if {[namespace eval $spc [list namespace origin $command]] == \ [namespace eval $spc [list namespace which $command]]} { lappend procs $command } } } else { set procs "" } set matches [namespace eval $spc concat ${commands} ${procs}] set namespaces [namespace children $spc ${cmd}] if {![llength ${matches}] && 1 == [llength ${namespaces}]} { set matches [CommandCompletion {} ${action} ${namespaces} ${pre}] # puts stderr \nmatches=|$matches| return $matches } # make `namespaces' having exactly # the same number of colons as `cmd'. # regsub -all {^:*} $spc $pre spc set matches [FullQualifiedMatches ${spc} ${matches}] # puts stderr \nmatches3=|$matches| return [string trim "${matches} ${namespaces}"] } #** # check, if the first argument starts with a '[' # and must be evaluated before continuing. # NOTE: trims the `line'. # 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 oldlen [string length ${line}] set line [string trim ${line}] set diff [expr [string length $line] - $oldlen] incr start $diff incr end $diff 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 # part == $b # start == 5 # end == 7 # line == "$puts $b" # proc ScriptCompleter {part start end line} { # puts stderr "(ScriptCompleter) |$part| $start $end |$line|" # if the character before the cursor is a terminating # quote and the user wants completion, we insert a white # space here. # set char [string index $line [expr $end - 1]] if {"\}" == $char} { append $part " " return [list $part] } 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] # 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 $b # part == put # start == 10 # end == 13 # line == "puts bla; put $b" # [SplitLine] --> {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 [SplitLine $start $line]]} { set new_start [lindex $sub 0] set new_end [expr $end - ($start - $new_start)] set new_line [lindex $sub 1] # puts stderr "(SplitLine) $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 all [CommandCompletion ${part}] # puts stderr "(ScriptCompleter) all=$all" #puts \nmatches=$matches\n # return [Format $all $part] return [TryFromList $part $all] } else { # try to use $pos further ... # puts stderr |$line| # if {"." == [string index [string trim ${line}] 0]} { set alias WIDGET } else { # the double `lindex' strips {} or quotes. # the subst enables variables containing # command names. # set alias [uplevel [info level] \ subst [lindex [lindex [QuoteQuotes ${line}] 0] 0]] # make `alias' a fully qualified name. # this can raise an error, if alias is # no valid command. # if {[catch [list set alias [namespace origin $alias]]]} { return "" } # strip leading ::'s. # regsub -all {^::} $alias {} alias set namespc [namespace qualifiers $alias] set alias [namespace tail $alias] } foreach cmd [list ${alias} tclreadline_complete_unknown] { # puts stderr ${namespc}complete(${cmd}) if {"" != [namespace eval ::tclreadline::${namespc} \ [list info procs complete(${cmd})]] } { # puts found=|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::${namespc} \ [list info args complete($cmd)]]]] } { error [list complete(${cmd}) takes ${arguments} \ arguments, but should take exactly 6.] } # remove leading quotes # set mod [StripPrefix $part] # puts stderr mod=$mod if {[catch [list set script_result \ [namespace eval ::tclreadline::${namespc} \ [list complete(${cmd}) $part $start $end $line $pos $mod]]]\ ::tclreadline::errorMsg] } { error [list error during evaluation of `complete(${cmd})'] } # puts stderr \nscript_result=|${script_result}| return ${script_result} } # set namespc ""; # no qualifiers for tclreadline_complete_unknown } # no specific command completer found. return "" } error "{NOTREACHED (this is probably an error)}" } # explicit command completers # # ------------------------------------- # TCL # ------------------------------------- proc complete(after) {text start end line pos mod} { set sub [Lindex $line 1] # puts \npos=$pos switch -- $pos { 1 { return [CompleteFromList ${text} { cancel idle info}] } 2 { switch -- $sub { cancel { return [CompleteFromList $text "