# -*- tclsh -*- # FILE: "/home/joze/src/tclreadline/tclreadlineCompleter.tcl" # LAST MODIFICATION: "Tue Sep 21 21:19:07 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 # - better completion for CompleteListFromList: # RemoveUsedOptions ... # - namespace eval fred {... <-- continue with a # substitution in fred. # - set tclreadline::pro doesn't work # set ::tclreadline::pro does # # - TextObj ... # namespace eval tclreadline { # the following three are from the icccm # and used in complete(selection) and # descendants. # variable selection-selections { PRIMARY SECONDARY CLIPBOARD } variable selection-types { ADOBE_PORTABLE_DOCUMENT_FORMAT APPLE_PICT BACKGROUND BITMAP CHARACTER_POSITION CLASS CLIENT_WINDOW COLORMAP COLUMN_NUMBER COMPOUND_TEXT DELETE DRAWABLE ENCAPSULATED_POSTSCRIPT ENCAPSULATED_POSTSCRIPT_INTERCHANGE FILE_NAME FOREGROUND HOST_NAME INSERT_PROPERTY INSERT_SELECTION LENGTH LINE_NUMBER LIST_LENGTH MODULE MULTIPLE NAME ODIF OWNER_OS PIXMAP POSTSCRIPT PROCEDURE PROCESS STRING TARGETS TASK TEXT TIMESTAMP USER } variable selection-formats { APPLE_PICT ATOM ATOM_PAIR BITMAP COLORMAP COMPOUND_TEXT DRAWABLE INTEGER NULL PIXEL PIXMAP7 SPAN STRING TEXT WINDOW } namespace export \ TryFromList CompleteFromList DisplayHints Rehash \ PreviousWord CommandCompletion RemoveUsedOptions \ HostList ChannelId InChannelId OutChannelId \ Lindex Llength CompleteBoolean WidgetChildren # set tclreadline::trace to 1, if you # want to enable explicit trace calls. # variable trace # set tclreadline::trace_procs to 1, if you # want to enable tracing every entry to a proc. # variable trace_procs if {[info exists trace_procs] && $trace_procs} { ::proc proc {name arguments body} { ::proc $name $arguments [subst -nocommands { TraceText [lrange [info level 0] 1 end] $body }] } } else { ;# !$trace_procs catch {rename ::tclreadline::proc ""} } if {[info exists trace] && $trace} { ::proc TraceReconf {args} { eval .tclreadline_trace.scroll set $args .tclreadline_trace.text see end } ::proc AssureTraceWindow {} { variable trace if {![info exists trace]} { return 0 } if {!$trace} { return 0 } if {![winfo exists .tclreadline_trace.text]} { toplevel .tclreadline_trace text .tclreadline_trace.text \ -yscrollcommand { tclreadline::TraceReconf } \ -wrap none scrollbar .tclreadline_trace.scroll \ -orient vertical \ -command { .tclreadline_trace.text yview } pack .tclreadline_trace.text -side left -expand yes -fill both pack .tclreadline_trace.scroll -side right -expand yes -fill y } else { raise .tclreadline_trace } return 1 } ::proc TraceVar vT { if {![AssureTraceWindow]} { return } upvar $vT v if {[info exists v]} { .tclreadline_trace.text insert end \ "([lindex [info level -1] 0]) $vT=|$v|\n" } # silently ignore unset variables. } ::proc TraceText txt { if {![AssureTraceWindow]} { return } .tclreadline_trace.text insert end \ [format {%32s %s} ([lindex [info level -1] 0]) $txt\n] } } else { ::proc TraceReconf args {} ::proc AssureTraceWindow args {} ::proc TraceVar args {} ::proc TraceText args {} } #** # 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. # If inhibit is non-zero, the result will be # formatted such that readline will not insert # a space after a complete (single) match. # proc TryFromList {text lst {allow ""} {inhibit 0}} { # 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}) && \ -1 == [string first ${null} ${allow}] } { set completion [string trim "[list $text] $lst"] } else { set completion [string trim ${pre}${matches}[Right ${pre}]] } if {$inhibit} { return [list $completion {}] } else { return $completion } } 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. If inhibit is non-zero, the result # will be formatted such that readline will not insert # a space after a complete (single) match. # proc CompleteFromList {text lst {allow ""} {inhibit 0}} { set result [TryFromList ${text} ${lst} ${allow} $inhibit] 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 ... # But on the other side, if the user supplies # a valid host table in tclreadline::hosts # before entering the event loop, this proc # will return this list. # proc HostList {} { # read the host table only once. # variable hosts if {![info exists hosts]} { catch { set hosts "" set id [open /etc/hosts r] 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] } #** # invoke cmd with a (hopefully) invalid string and # parse the error message to get an option list. # The strings are carefully chosen to match the # results produced by known tcl routines. It's a # pity, that not all object commands generate # standard error messages! # # @param cmd # @return list of options for cmd # @date Sep-14-1999 # proc TrySubCmds {text cmd} { set trystring ---- # try the command with and w/o trystring. # Some commands, e.g. # .canvas bind # return an error if invoked w/o arguments # but not, if invoked with arguments. Breaking # the loop is eventually done at the end ... # for {set str ${trystring}} {1} {set str ""} { set code [catch {set result [eval ${cmd} ${str}]} msg] set result "" if {$code} { set tcmd [string trim ${cmd}] # puts stderr msg=$msg # XXX see # tclIndexObj.c # tkImgPhoto.c # XXX if {[regexp \ {(bad|ambiguous|unrecognized) .*"----": *must *be( .*$)} \ ${msg} all junk 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} } } if {[string length ${result}] && \ -1 == [string first ${trystring} ${result}] } { return [TryFromList ${text} ${result}] } } elseif {[regexp \ "wrong # args: should be \"?${tcmd}\[^ \t\]*\(.*\[^\"\]\)" \ ${msg} all hint] } { # XXX see tclIndexObj.c XXX if {-1 == [string first ${trystring} ${hint}]} { return [DisplayHints [list <[string trim $hint]>]] } } else { # check, if it's a blt error msg ... # set msglst [split ${msg} \n] foreach line ${msglst} { if {[regexp "${tcmd}\[ \t\]\+\(\[^ \t\]*\)\[^:\]*$" \ ${line} all sub] } { lappend result [list ${sub}] } } if {[string length ${result}] && \ -1 == [string first ${trystring} ${result}] } { return [TryFromList ${text} ${result}] } } } if {"" == ${str}} { break } } return "" } #** # try to get casses for commands which # allow `configure' (cget). # @param command. # @param optionsT where the table will be stored. # @return number of options # @date Sat-Sep-18 # proc ClassTable {cmd} { # first we build an option table. # We always use `configure' here, # because cget will not return the # option table. # if {[catch [list set option_table [eval ${cmd} configure]] msg]} { return "" } set classes "" foreach optline ${option_table} { if {5 != [llength ${optline}]} continue else { lappend classes [lindex ${optline} 2] } } return ${classes} } #** # try to get options for commands which # allow `configure' (cget). # @param command. # @param optionsT where the table will be stored. # @return number of options # @date Sep-14-1999 # proc OptionTable {cmd optionsT} { upvar $optionsT options # first we build an option table. # We always use `configure' here, # because cget will not return the # option table. # if {[catch [list set option_table [eval ${cmd} configure]] msg]} { return 0 } foreach optline ${option_table} { if {5 != [llength ${optline}]} continue else { lappend options(switches) [lindex ${optline} 0] lappend options(value) [lindex ${optline} 4] } } return [llength ${option_table}] } #** # try to complete a `cmd configure|cget ..' from the command's options. # @param text start line cmd, standard tclreadlineCompleter arguments. # @return -- a flag indicating, if (cget|configure) was found. # @return resultT -- a tclreadline completer formatted string. # @date Sep-14-1999 # proc CompleteFromOptions {text start line resultT} { upvar ${resultT} result set result "" # check if either `configure' or `cget' is present. # set lst [ProperList ${line}] foreach keyword {configure cget} { set idx [lsearch ${lst} ${keyword}] if {-1 != ${idx}} { break } } if {-1 == ${idx}} { return 0 } if {[regexp {(cget|configure)$} ${line}]} { # we are at the end of (configure|cget) # but there's no space yet. # set result ${text} return 1 } # separate the command, but exclude (cget|configure) # because cget won't return the option table. Instead # OptionTable always uses `configure' to get the # option table. # set cmd [lrange ${lst} 0 [expr ${idx} - 1]] TraceText ${cmd} if {0 < [OptionTable ${cmd} options]} { set prev [PreviousWord ${start} ${line}] if {-1 != [set found [lsearch -exact $options(switches) ${prev}]]} { # complete only if the user has not # already entered something here. # if {![llength ${text}]} { # check first, if the SpecificSwitchCompleter # knows something about this switch. (note that # `prev' contains the switch). The `0' as last # argument makes the SpecificSwitchCompleter # returning "" if it knows nothing specific # about this switch. # set values [SpecificSwitchCompleter \ ${text} ${start} ${line} ${prev} 0] if [string length ${values}] { set result ${values} return 1 } else { set val [lindex $options(value) ${found}] if [string length ${val}] { # return the old value only, if it's non-empty. # Use this double list to quote option # values which have to be quoted. # set result [list [list ${val}]] return 1 } else { set result "" return 1 } } } else { set result [SpecificSwitchCompleter \ ${text} ${start} ${line} ${prev} 1] return 1 } } else { set result [CompleteFromList ${text} \ [RemoveUsedOptions ${line} $options(switches)]] return 1 } } return 1 } proc ObjectClassCompleter {text start end line pos resultT} { upvar ${resultT} result set cmd [Lindex ${line} 0] if {"." == [string index ${line} 0]} { # it's a widget. Try to get it's class name. # if {![catch [list set class [winfo class [Lindex ${line} 0]]]]} { if {[string length [info proc ${class}Obj]]} { set result [${class}Obj ${text} ${start} ${end} ${line} ${pos}] return 0 } } } if {![catch [list set type [image type ${cmd}]]]} { switch -- ${type} { photo { set result [PhotoObj ${text} ${start} ${end} ${line} ${pos}] return 1 } default { # let the fallback completers do the job. return 0 } } } return 0 } proc CompleteFromOptionsOrSubCmds {text start end line pos} { if [CompleteFromOptions ${text} ${start} ${line} from_opts] { # always return, if CompleteFromOptions returns non-zero, # that means (configure|cget) were present. This ensures # that TrySubCmds will not configure something by chance. # return ${from_opts} } else { # puts stderr \n\n[lrange [ProperList ${line}] 0 [expr $pos - 1]]\n return [TrySubCmds ${text} \ [lrange [ProperList ${line}] 0 [expr $pos - 1]]] } return "" } #** # TODO: shit. make this better! # @param text, a std completer argument (current word). # @param fullpart, the full text of the current position. # @param lst, the list to complete from. # @param pre, leading `quote'. # @param sep, word separator. # @param post, trailing `quote'. # @return a formatted completer string. # @date Sep-15-1999 # proc CompleteListFromList {text fullpart lst pre sep post} { # puts stderr "" # puts stderr text=|$text| # puts stderr lst=|$lst| # puts stderr pre=|$pre| # puts stderr sep=|$sep| # puts stderr post=|$post| if {![string length ${fullpart}]} { # nothing typed so far. Insert a $pre # and inhibit further completion. # return [list ${pre} {}] } elseif {${post} == [String index ${text} end]} { # finalize, append the post and a space. # set diff \ [expr [CountChar ${fullpart} ${pre}] - [CountChar ${fullpart} ${post}]] for {set i 0} {${i} < ${diff}} {incr i} { append text ${post} } append text " " return ${text} } elseif {![regexp -- ^\(.*\[${pre}${sep}\]\)\(\[^${pre}${sep}\]*\)$ \ ${text} all left right] } { set left {} set right ${text} } # TraceVar left # TraceVar right # puts stderr \nleft=|$left| # puts stderr \nright=|$right| set exact_matches [MatchesFromList ${right} ${lst}] # TODO this is awkward. Think of making it better! # if {1 == [llength ${exact_matches}] && -1 != [lsearch ${lst} ${right}] } { #set completion [CompleteFromList ${right} [list ${sep} ${post}] 1] return [list ${left}${right}${sep} {}] } else { set completion [CompleteFromList ${right} ${lst} "" 1] } # puts stderr \ncompletion=|$completion| if {![string length [lindex $completion 0]]} { return [concat [list ${left}] [lrange $completion 1 end]] } elseif {[string length ${left}]} { return [list ${left}]${completion} } else { return ${completion} } return "" } 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 {-1 == [string first ${word} ${line}]} { lappend new ${word} } } # check if the last word in the line is an options # and if this word is at the very end of the line, # that means no space after. # If this is so, the word is stuffed into the result, # so that it can be completed -- probably with a space. # set last [Lindex ${line} end] if {[expr [string last ${last} ${line}] + [string length ${last}]] == \ [string length ${line}] } { if {-1 != [lsearch ${opts} ${last}]} { lappend new ${last} } } return [string trim ${new}] } proc Alert {} { ::tclreadline::readline bell } #** # 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 PreviousWordOfIncompletePosition {start line} { return [lindex [ProperList [string range ${line} 0 ${start}]] end] } 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 } #** # 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} } #** # save `lrange' (see above). # proc Lrange {line first last} { if {[catch [list set range [lrange ${line} ${first} ${last}]]]} { set rest [IncompleteListRemainder ${line}] set proper [ProperList ${line}] if {[catch [list set range [lindex ${proper} ${first} ${last}]]]} { return {} } if {"end" == ${last} || [Llength ${line}] == ${last}} { append sub " ${rest}" } } return ${range} } #** # Lunique -- remove duplicate entries from a sorted list # @param list # @return unique list # @author Johannes Zellner # @date Sep-19-1999 # proc Lunique lst { set unique "" foreach element ${lst} { if {${element} != [lindex ${unique} end]} { lappend unique ${element} } } return ${unique} } #** # string function, which works also for older versions # of tcl, which don't have the `end' index. # I tried also defining `string' and thus overriding # the builtin `string' which worked, but slowed down # things considerably. So I decided to call `String' # only if I really need the `end' index. # proc String args { if {[info tclversion] < 8.2} { switch [lindex $args 1] { range - index { if {"end" == [lindex $args end]} { set str [lindex $args 2] lreplace args end end [expr [string length $str] - 1] } } } } return [eval string $args] } 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 {"#" != [string index ${level} 0]} { 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 BraceOrCommand {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 ::}} { # get the leading colons in `cmd'. regexp {^:*} ${cmd} pre return [CommandCompletionWithPre $cmd $action $spc $pre] } proc CommandCompletionWithPre {cmd action spc pre} { # puts stderr "(CommandCompletion) cmd=|$cmd|" # puts stderr "(CommandCompletion) action=|$action|" # puts stderr "(CommandCompletion) spc=|$spc|" set cmd [StripPrefix ${cmd}] set quali [namespace qualifiers ${cmd}] if {[string length ${quali}]} { # puts stderr \nquali=|$quali| set matches [CommandCompletionWithPre \ [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 $proc]] == \ [namespace eval $spc [list namespace which $proc]]} { lappend procs $proc } } } 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 [CommandCompletionWithPre {} ${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 line [string trimleft ${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]]} { # XXX # note that line will be [string trimleft'ed] # after PartPosition. # XXX # 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 # set namespc ""; # widgets are always in the global # } 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] # } # try first a specific completer, then, and only then # the tclreadline_complete_unknown. # 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}| if {![string length ${script_result}] && \ "tclreadline_complete_unknown" == ${cmd} } { # as we're here, the tclreadline_complete_unknown # returned an empty string. Fall thru and try # further fallback completers. # } else { # return also empty strings, if # they're from a specific completer. # TraceText script_result=|${script_result}| return ${script_result} } } # set namespc ""; # no qualifiers for tclreadline_complete_unknown } # as we've reached here no valid specific completer # was found. Check, if it's a proc and return the # arguments. # if {![string length ${namespc}]} { set namespc :: } if {[string length [uplevel [info level] \ namespace eval ${namespc} [list ::info proc $alias]]]} { set args [uplevel [info level] \ namespace eval ${namespc} [list info args $alias]] set arg [lindex $args [expr $pos - 1]] if {"" != $arg && "args" != $arg} { if {[uplevel [info level] namespace eval \ ${namespc} [list info default $alias $arg junk]]} { return [DisplayHints ?$arg?] } else { return [DisplayHints <$arg>] } } } # check if the command is an object of known class. # if [ObjectClassCompleter ${part} ${start} ${end} ${line} ${pos} res] { return ${res} } # Ok, also no proc. Try to do the same as for widgets now: # try to complete from the option table if the subcommand # is `configure' or `cget' otherwise try to get further # subcommands. # return [CompleteFromOptionsOrSubCmds \ ${part} ${start} ${end} ${line} ${pos}] } 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 "