Index: tclreadline.c ================================================================== --- tclreadline.c +++ tclreadline.c @@ -1,10 +1,10 @@ /* ================================================================== - FILE: "/diska/home/joze/src/tclreadline/tclreadline.c" - LAST MODIFICATION: "Tue Sep 14 11:57:42 1999 (joze)" + FILE: "/home/joze/src/tclreadline/tclreadline.c" + LAST MODIFICATION: "Wed Sep 15 01:00:43 1999 (joze)" (C) 1998, 1999 by Johannes Zellner, $Id$ --- tclreadline -- gnu readline for tcl @@ -644,10 +644,11 @@ for (i = 0; i < objc; i++) { matches[i] = strdup(Tcl_GetStringFromObj(objv[i], &length)); if (1 == objc && !strlen(matches[i])) { FREE(matches[i]); FREE(matches); + Tcl_ResetResult(tclrl_interp); /* clear result space */ return (char**) NULL; } } /** Index: tclreadlineCompleter.tcl ================================================================== --- tclreadlineCompleter.tcl +++ tclreadlineCompleter.tcl @@ -1,8 +1,8 @@ # -*- tclsh -*- -# FILE: "/diska/home/joze/src/tclreadline/tclreadlineCompleter.tcl" -# LAST MODIFICATION: "Tue Sep 14 16:17:25 1999 (joze)" +# FILE: "/home/joze/src/tclreadline/tclreadlineCompleter.tcl" +# LAST MODIFICATION: "Wed Sep 15 02:59:18 1999 (joze)" # (C) 1998, 1999 by Johannes Zellner, # $Id$ # --- # # tclreadline -- gnu readline for tcl @@ -49,68 +49,78 @@ # 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 - } +# 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} { + 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. -# -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} - } +# 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 {inhibit 0}} { + set result [TryFromList ${text} ${lst} "" $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}] + 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 @@ -120,29 +130,29 @@ # 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] - } - } - } + 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 @@ -151,37 +161,37 @@ # 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 + # 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}"] + return [string trim "{} ${lst}"] } #** # find (partial) matches for `text' in `lst'. Ring # the bell and return the whole list, if the user @@ -191,27 +201,27 @@ # 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] + 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. @@ -219,214 +229,214 @@ # @param cmd # @return list of options for cmd # @date Sep-14-1999 # 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} + 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 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} + 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}] + 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 + 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} + # 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 "" + 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 - } + 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]] + 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}] - } + 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] + 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] + 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}"]] - } + 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 + 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 + 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 @@ -443,13 +453,13 @@ # 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]]] + 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} { @@ -460,41 +470,41 @@ # return [llength $pre_text] # } proc Right {left} { - # puts left=$left - if {"\"" == $left} { - return "\"" - } elseif {"\\\"" == $left} { - return "\\\"" - } elseif {"\{" == $left} { - return "\}" - } elseif {"\\\{" == $left} { - return "\\\}" - } - return "" + # 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 {} - } + 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 + # 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 @@ -502,33 +512,33 @@ # 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] + 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] + 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. @@ -535,239 +545,239 @@ # 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 + 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 + 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 - } + # 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 - } + 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 "" + 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] - } + 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} + 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] + return [CommandCompletion ${cmd} procs] } proc CommandsOnlyCompletion {cmd} { - return [CommandCompletion ${cmd} commands] + 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] + # 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}"] + # 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. @@ -774,42 +784,42 @@ # 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} + # 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 @@ -817,193 +827,194 @@ # 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 - } - - # as we've reached here no valid specific completer - # was found. Check, if it's a proc and return the - # arguments. - # - if {[string length [uplevel [info level] info proc $alias]]} { - set args [uplevel [info level] info args $alias] - set arg [lindex $args [expr $pos - 1]] - if {"" != $arg && "args" != $arg} { - if {[uplevel [info level] info default $alias $arg junk]} { - return [DisplayHints ?$arg?] - } else { - return [DisplayHints <$arg>] - } - } - } - - - # Ok, also no proc. Try to do the same as for widgets now: - # try to get at least the first option from an error output. - # if the subcommand is configure or cget, try to get the - # option table. - # - switch -- $pos { - 1 { - set cmds [TrySubCmds ${alias}] - if {[llength ${cmds}]} { - return [TryFromList ${part} ${cmds}] - } - } - default { - set sub [Lindex $line 1] - switch -- $sub { - configure - - cget { - if {[OptionTable ${widget} options]} { - } - } - } - } - } - - - # no specific command completer found. - return "" - } - error "{NOTREACHED (this is probably an error)}" + # 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 + set namespc "" + } 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 + } + + # as we've reached here no valid specific completer + # was found. Check, if it's a proc and return the + # arguments. + # + if {[string length [uplevel [info level] info proc $alias]]} { + set args [uplevel [info level] info args $alias] + set arg [lindex $args [expr $pos - 1]] + if {"" != $arg && "args" != $arg} { + if {[uplevel [info level] info default $alias $arg junk]} { + return [DisplayHints ?$arg?] + } else { + return [DisplayHints <$arg>] + } + } + } + + + # Ok, also no proc. Try to do the same as for widgets now: + # try to get at least the first option from an error output. + # if the subcommand is configure or cget, try to get the + # option table. + # + switch -- $pos { + 1 { + set cmds [TrySubCmds ${alias}] + if {[llength ${cmds}]} { + return [TryFromList ${part} ${cmds}] + } + } + default { + set sub [Lindex $line 1] + switch -- $sub { + configure - + cget { + return [CompleteFromOptions \ + ${part} ${start} ${line} ${alias}] + } + } + } + } + + + # no specific command completer found. + return "" + } + error "{NOTREACHED (this is probably an error)}" } # explicit command completers # @@ -1011,205 +1022,205 @@ # ------------------------------------- # 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 "