@@ -1,8 +1,8 @@ #!/usr/locanl/bin/tclsh # FILE: "/home/joze/src/tclreadline/tclreadlineCompleter.tcl" -# LAST MODIFICATION: "Mon Sep 13 02:21:21 1999 (joze)" +# LAST MODIFICATION: "Tue Sep 14 01:55:17 1999 (joze)" # (C) 1998, 1999 by Johannes Zellner, # $Id$ # --- # # tclreadline -- gnu readline for tcl @@ -145,19 +145,23 @@ #** # 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 id [open /etc/hosts r] 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] @@ -205,10 +209,48 @@ lappend result ${word} } } return [string trim $result] } + +#** +# invoke cmd with a (hopefully) invalid string and +# parse the error message to get an option list. +# +# @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} +} proc FirstNonOption {line} { set expr_pos 1 foreach word [lrange ${line} 1 end] {; # 0 is the command itself if {"-" != [string index ${word} 0]} { @@ -657,26 +699,26 @@ proc CommandsOnlyCompletion {cmd} { return [CommandCompletion ${cmd} commands] } -proc CommandCompletion {cmd {action both} {spc ::} {pre UNDEFINED}} { +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|" - # 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 \ + set matches [CommandCompletionWithPre \ [namespace tail ${cmd}] ${action} ${spc}${quali} ${pre}] # puts stderr \nmatches1=|$matches| return $matches } set cmd [string trim ${cmd}]* @@ -697,23 +739,23 @@ 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 + 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 [CommandCompletion {} ${action} ${namespaces} ${pre}] + set matches [CommandCompletionWithPre {} ${action} ${namespaces} ${pre}] # puts stderr \nmatches=|$matches| return $matches } # make `namespaces' having exactly @@ -830,22 +872,26 @@ # 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| # @@ -907,10 +953,41 @@ # 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} { + 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. + # + switch -- $pos { + 1 { + set cmds [TrySubCmds ${alias}] + if {[llength ${cmds}]} { + return [TryFromList ${part} ${cmds}] + } + } + } + + # no specific command completer found. return "" } error "{NOTREACHED (this is probably an error)}" } @@ -1051,12 +1128,13 @@ 2 { return [DisplayHints ?varName?] } } return "" } -# proc complete(cd) {text start end line pos mod} { -# } +proc complete(cd) {text start end line pos mod} { + return "" +} proc complete(clock) {text start end line pos mod} { set cmd [Lindex $line 1] switch -- $pos { 1 { @@ -2231,21 +2309,39 @@ vcompare - vsatisfies { return [DisplayHints ] } } } 3 { + set versions "" + catch [list set versions [package versions [Lindex $line 2]]] switch -- $cmd { forget {} - ifneeded { return [DisplayHints ] } - provide { return [DisplayHints ?version?] } + ifneeded { + if {"" != $versions} { + return [CompleteFromList ${text} $versions] + } else { + return [DisplayHints ] + } + } + provide { + if {"" != $versions} { + return [CompleteFromList ${text} $versions] + } else { + return [DisplayHints ?version?] + } + } versions {} present - require { if {"-exact" == [PreviousWord ${start} ${line}]} { return [CompleteFromList ${mod} [package names]] } else { - return [DisplayHints ?version?] + if {"" != $versions} { + return [CompleteFromList ${text} $versions] + } else { + return [DisplayHints ?version?] + } } } names {} unknown {} vcompare - @@ -2771,13 +2867,52 @@ } } return "" } +# --- TCLREADLINE PACKAGE --- + +# create a tclreadline namespace inside +# tclreadline and import some commands. +# +namespace eval tclreadline { + catch { + namespace import \ + ::tclreadline::DisplayHints \ + ::tclreadline::CompleteFromList \ + ::tclreadline::Lindex + } +} + +proc tclreadline::complete(readline) {text start end line pos mod} { + set cmd [Lindex $line 1] + switch -- $pos { + 1 { return [CompleteFromList ${text} { + read initialize write add complete + customcompleter builtincompleter eofchar}] + } + 2 { + switch -- $cmd { + read {} + initialize {} + write {} + add { return [DisplayHints ] } + completer { return [DisplayHints ] } + customcompleter { return [DisplayHints ?scriptCompleter?] } + builtincompleter { return [DisplayHints ?boolean?] } + eofchar { return [DisplayHints ?script?] } + } + } + } + return "" +} + +# --- END OF TCLREADLINE PACKAGE --- + proc complete(tell) {text start end line pos mod} { switch -- $pos { - 1 { return [ChannelId ${mod}] } + 1 { return [ChannelId ${text}] } } return "" } proc complete(time) {text start end line pos mod} { @@ -2928,44 +3063,17 @@ # ------------------------------------- # TK # ------------------------------------- -# generic widget configuration - -proc TrySubCmds {cmd} { - set trystring ____ - set result "" - if [catch {set result [${cmd} ${trystring}]} msg] { - if {[regexp {bad *option.*____.*: *must *be( .*$)} ${msg} all raw]} { - regsub -all -- , ${raw} { } raw - set len [llength ${raw}] - set len_2 [expr ${len} - 2] - for {set i 0} {${i} < ${len}} {incr i} { - set word [lindex ${raw} ${i}] - if {"or" != ${word} && ${i} != ${len_2}} { - lappend result ${word} - } - - } - } else { - # check, if it's a blt error msg ... - # - set msglst [split ${msg} \n] - foreach line ${msglst} { - if {[regexp "${cmd}\[ \t\]\+\(\[^ \t\]*\)\[^:\]*$" \ - ${line} all sub]} { - lappend result [list ${sub}] - } - } - } - } - return ${result} -} - -proc WidgetList {pattern} { +# GENERIC WIDGET CONFIGURATION + +proc WidgetChildren {pattern} { regsub {^([^\.])} ${pattern} {\.\1} pattern + if {![string length ${pattern}]} { + set pattern . + } if {[winfo exists ${pattern}]} { return [winfo children ${pattern}] } else { regsub {.[^.]*$} $pattern {} pattern if {[winfo exists ${pattern}]} { @@ -2973,10 +3081,18 @@ } else { return "" } } } + +proc WidgetDescendants {pattern} { + set tree [WidgetChildren ${pattern}] + foreach widget $tree { + append tree " [WidgetDescendants $widget]" + } + return $tree +} proc complete(WIDGET) {text start end line pos mod} { set widget [lindex ${line} 0] set cmd [lindex ${line} 1] @@ -2990,42 +3106,65 @@ lappend options(switches) [lindex ${optline} 0] lappend options(value) [lindex ${optline} 4] } } - if {1 >= ${pos}} { - set cmds [TrySubCmds ${widget}] - if {[llength ${cmds}]} { - return [TryFromList ${mod} ${cmds}] - } - } elseif {2 <= ${pos} && - ([string match ${cmd}* cget] || \ - [string match ${cmd}* configure])} { - set prev [PreviousWord ${start} ${line}] - #puts \nprev=|$prev| - #puts switches=|$options(switches)| - #puts found=[lsearch -exact ${prev} $options(switches)] - if {-1 != [set found [lsearch -exact $options(switches) ${prev}]]} { - if {![llength ${mod}]} { - return [list "[lindex $options(value) ${found}]"] - } - } else { - return [TryFromList ${mod} $options(switches)] + switch -- $pos { + 1 { + set cmds [TrySubCmds ${widget}] + if {[llength ${cmds}]} { + return [TryFromList ${mod} ${cmds}] + } + } + 2 { + if {([string match ${cmd}* cget] || \ + [string match ${cmd}* configure]) + } { + set prev [PreviousWord ${start} ${line}] + #puts \nprev=|$prev| + #puts switches=|$options(switches)| + #puts found=[lsearch -exact ${prev} $options(switches)] + if {-1 != [set found \ + [lsearch -exact $options(switches) ${prev}]] + } { + if {![llength ${mod}]} { + return [list "[lindex $options(value) ${found}]"] + } + } else { + return [TryFromList ${mod} $options(switches)] + } + } } } return "" } + +# SPECIFIC TK COMMAND COMPLETERS + +proc complete(bell) {text start end line pos mod} { + switch -- $pos { + 1 { return [CompleteFromList ${text} -displayof] } + 2 { + if {"-displayof" == [PreviousWord ${start} ${line}]} { + return [CompleteFromList ${text} [WidgetDescendants ${text}]] + } + } + } +} proc complete(winfo) {text start end line pos mod} { set cmd [lindex ${line} 1] - if {1 >= ${pos}} { - set cmds [TrySubCmds winfo] - if {[llength ${cmds}]} { - return [TryFromList ${mod} ${cmds}] + switch -- $pos { + 1 { + set cmds [TrySubCmds winfo] + if {[llength ${cmds}]} { + return [TryFromList ${text} ${cmds}] + } } - } elseif {2 == ${pos}} { - return [TryFromList ${mod} [WidgetList ${mod}]] + 2 { + return [TryFromList ${text} [WidgetChildren ${text}]] + } } return "" } }; # namespace tclreadline