Index: tclreadline.c ================================================================== --- tclreadline.c +++ tclreadline.c @@ -1,10 +1,10 @@ /* ================================================================== - FILE: "/disk01/home/joze/src/tclreadline/tclreadline.c" - LAST MODIFICATION: "Thu Sep 16 15:43:29 1999 (joze)" + FILE: "/home/joze/src/tclreadline/tclreadline.c" + LAST MODIFICATION: "Fri Sep 17 23:34:52 1999 (joze)" (C) 1998, 1999 by Johannes Zellner, $Id$ --- tclreadline -- gnu readline for tcl Index: tclreadlineCompleter.tcl ================================================================== --- tclreadlineCompleter.tcl +++ tclreadlineCompleter.tcl @@ -1,8 +1,8 @@ # -*- tclsh -*- -# FILE: "/disk01/home/joze/src/tclreadline/tclreadlineCompleter.tcl" -# LAST MODIFICATION: "Fri Sep 17 18:41:10 1999 (joze)" +# FILE: "/home/joze/src/tclreadline/tclreadlineCompleter.tcl" +# LAST MODIFICATION: "Sat Sep 18 04:27:54 1999 (joze)" # (C) 1998, 1999 by Johannes Zellner, # $Id$ # --- # # tclreadline -- gnu readline for tcl @@ -87,14 +87,15 @@ return 0 } if {![winfo exists .tclreadline_trace.text]} { toplevel .tclreadline_trace text .tclreadline_trace.text \ - -yscrollcommand { tclreadline::TraceReconf } + -yscrollcommand { tclreadline::TraceReconf } \ + -wrap none scrollbar .tclreadline_trace.scroll \ - -orient vertical \ - -command { .tclreadline_trace.text yview } + -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 } @@ -306,52 +307,281 @@ } #** # 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 # -# @param cmd -# @return list of options for cmd +proc TrySubCmds {text cmd} { + + set trystring ---- + set bla 0 + + # 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 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 TrySubCmds {cmd} { - set trystring ____ - set result "" - if [catch {set result [eval ${cmd} ${trystring}]} msg] { - set tcmd [string trim ${cmd}] - # puts stderr msg=$msg - if {[regexp {(bad|ambiguous) .*"____": *must *be( .*$)} ${msg} \ - all junk raw] - } {; # XXX see tclIndexObj.c XXX - 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} - } - - } - } elseif {[regexp "wrong # args: should be \"${tcmd}\(.*\)\"" \ - ${msg} all hint] - } {; # XXX see tclIndexObj.c XXX - set result [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}] - } - } - } - } - return ${result} +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 tclreadline completer formatted string. +# @date Sep-14-1999 +# +proc CompleteFromOptions {text start line} { + + # 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 + } + + if {[regexp {(cget|configure)$} ${line}]} { + # we are at the end of (configure|cget) + # but there's no space yet. + # + return ${text} + } + + # 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}]} { + # use this double list to quote option + # values which have to be quoted. + # + return [list [list [lindex $options(value) ${found}]]] + } + + } else { + return [CompleteFromList ${text} \ + [RemoveUsedOptions ${line} $options(switches)]] + } + } + return "" +} + +proc ObjectClassCompleter {text start end line pos} { + 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]]} { + return [${class}Obj ${text} ${start} ${end} ${line} ${pos}] + } + } + } + if {![catch [list image type ${cmd}]]} { + return [ImageObj ${text} ${start} ${end} ${line} ${pos}] + } +} + +proc CompleteFromOptionsOrSubCmds {text start end line pos} { + set from_opts [CompleteFromOptions ${text} ${start} ${line}] + if {[string length ${from_opts}]} { + 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 {[regexp ${post} ${text}]} { + + # 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 @@ -375,10 +605,26 @@ 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 {} { puts -nonewline \a @@ -991,10 +1237,15 @@ 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 @@ -1075,10 +1326,11 @@ # } 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 } @@ -1085,22 +1337,34 @@ # 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] + 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] info default $alias $arg junk]} { + 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. + # + set res [ObjectClassCompleter $part $start $end $line $pos] + if {[string length ${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. @@ -2729,11 +2993,11 @@ proc complete(set) {text start end line pos mod} { switch -- $pos { 1 { return [VarCompletion ${text}] } 2 { if {$text == "" || $text == "\"" || $text == "\{"} { - set line [QuoteQuotes $line] + # set line [QuoteQuotes $line] if {[catch [list set value [list [uplevel [info level] \ set [Lindex $line 1]]]] msg] } { return "" } else { @@ -2999,11 +3263,12 @@ namespace eval tclreadline { catch { namespace import \ ::tclreadline::DisplayHints \ ::tclreadline::CompleteFromList \ - ::tclreadline::Lindex + ::tclreadline::Lindex \ + ::tclreadline::CompleteBoolean } } proc tclreadline::complete(readline) {text start end line pos mod} { set cmd [Lindex $line 1] @@ -3202,11 +3467,11 @@ set pattern . } if {[winfo exists ${pattern}]} { return [concat ${pattern} [winfo children ${pattern}]] } else { - regsub {.[^.]*$} $pattern {} pattern + regsub {.[^.]*$} $pattern {.} pattern if {[winfo exists ${pattern}]} { return [concat ${pattern} [winfo children ${pattern}]] } else { return "" } @@ -3231,191 +3496,26 @@ } } return $toplevels } -#** -# 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 tclreadline completer formatted string. -# @date Sep-14-1999 -# -proc CompleteFromOptions {text start line} { - - # 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 - } - - # 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}]} { - # use this double list to quote option - # values which have to be quoted. - # - return [list [list [lindex $options(value) ${found}]]] - } - - } else { - return [CompleteFromList ${text} \ - [RemoveUsedOptions ${line} $options(switches)]] - } - } - return "" -} - -proc CompleteFromOptionsOrSubCmds {text start end line pos} { - set from_opts [CompleteFromOptions ${text} ${start} ${line}] - if {[string length ${from_opts}]} { - return ${from_opts} - } else { - # puts stderr \n\n[lrange [ProperList ${line}] 0 [expr $pos - 1]]\n - set cmds [TrySubCmds [lrange [ProperList ${line}] 0 [expr $pos - 1]]] - if {[llength ${cmds}]} { - return [TryFromList ${text} ${cmds}] - } - } - return "" -} - # TODO # write a dispatcher here, which gets the widget class name # and calls specific completers. # -proc complete(WIDGET_COMMAND) {text start end line pos mod} { - return [CompleteFromOptionsOrSubCmds ${text} ${start} ${end} ${line} ${pos}] -} +# proc complete(WIDGET_COMMAND) {text start end line pos mod} { +# return [CompleteFromOptionsOrSubCmds ${text} ${start} ${end} ${line} ${pos}] +# } proc EventuallyInsertLeadingDot {text fallback} { if {![string length ${text}]} { return [list . {}] } else { return [DisplayHints $fallback] } } -#** -# 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 {[regexp ${post} ${text}]} { - - # 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 "" -} - #** # SpecificSwitchCompleter # --- # @param text -- the word to complete. # @param start -- the char index of text's start in line @@ -3439,11 +3539,14 @@ -relief { return [CompleteFromList ${text} { raised sunken flat ridge solid groove }] } - default { return [DisplayHints <[String range ${prev} 1 end]>] } + default { + set prev [PreviousWord ${start} ${line}] + return [DisplayHints <[String range ${prev} 1 end]>] + } } } #** # CompleteWidgetConfigurations @@ -3478,10 +3581,28 @@ return [CompleteFromList ${text} [ToplevelWindows]] } } } } + +proc CompleteSequence {text fulltext} { + set modifiers { + Alt Control Shift Lock Double Triple + B1 B2 B3 B4 B5 Button1 Button2 Button3 Button4 Button5 + M M1 M2 M3 M4 M5 + Meta Mod1 Mod2 Mod3 Mod4 Mod5 + } + set events { + Activate Button ButtonPress ButtonRelease + Circulate Colormap Configure Deactivate Destroy + Enter Expose FocusIn FocusOut Gravity + Key KeyPress KeyRelease Leave Map Motion + MouseWheel Property Reparent Unmap Visibility + } + set sequence [concat ${modifiers} ${events}] + return [CompleteListFromList ${text} ${fulltext} ${sequence} < - >] +} proc complete(bind) {text start end line pos mod} { switch -- ${pos} { 1 { set widgets [WidgetChildren ${text}] @@ -3497,28 +3618,14 @@ } return [CompleteFromList ${text} \ [concat ${toplevels} ${widgets} ${toplevelClass} $rest]] } 2 { - set modifiers { - Alt Control Shift Lock Double Triple - B1 B2 B3 B4 B5 Button1 Button2 Button3 Button4 Button5 - M M1 M2 M3 M4 M5 - Meta Mod1 Mod2 Mod3 Mod4 Mod5 - } - set events { - Activate Button ButtonPress ButtonRelease - Circulate Colormap Configure Deactivate Destroy - Enter Expose FocusIn FocusOut Gravity - Key KeyPress KeyRelease Leave Map Motion - MouseWheel Property Reparent Unmap Visibility - } - set sequence [concat ${modifiers} ${events}] - return [CompleteListFromList ${text} \ - [Lindex $line 2] ${sequence} < - >] - } - 3 { + set fulltext [Lindex $line 2] + return [CompleteSequence ${text} ${fulltext}] + } + default { # return [DisplayHints {