#!/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, <johannes@zellner.org>
# $Id$
# ---
#
# tclreadline -- gnu readline for tcl
# Copyright (C) 1999  Johannes Zellner
#

    }
}

#**
# 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]
                    }
                }

    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.
#
# @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]} {
            break
        } else {

    return [CommandCompletion ${cmd} procs]
}

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}]*
    # puts stderr \ncmd=|$cmd|\n
    if {"procs" != ${action}} {

        set commands ""
    }
    if {"commands" != ${action}} {
        set all_procs [namespace eval $spc [list info procs ${cmd}]]
        # puts stderr procs=|$procs|
        set procs ""
        foreach proc $all_procs {
            if {[namespace eval $spc [list namespace origin $command]] == \
                [namespace eval $spc [list namespace which $command]]} {
                lappend procs $command
            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
    # the same number of colons as `cmd'.
    #

    # [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

                    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} {
                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)}"
}

    switch -- $pos {
        1 { return [DisplayHints <script>] }
        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 {
            return [CompleteFromList $text {clicks format scan seconds}]
        }

                names {}
                unknown { return [DisplayHints ?command?] }
                vcompare -
                vsatisfies { return [DisplayHints <version1>] }
            }
        }
        3 {
            set versions ""
            catch [list set versions [package versions [Lindex $line 2]]]
            switch -- $cmd {
                forget {}
                ifneeded {
                    if {"" != $versions} {
                        return [CompleteFromList ${text} $versions]
                    } else {
                ifneeded { return [DisplayHints <version>] }
                provide { return [DisplayHints ?version?] }
                        return [DisplayHints <version>]
                    }
                }
                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 {
                        if {"" != $versions} {
                            return [CompleteFromList ${text} $versions]
                        } else {
                        return [DisplayHints ?version?]
                            return [DisplayHints ?version?]
                        }
                    }
                }
                names {}
                unknown {}
                vcompare -
                vsatisfies { return [DisplayHints <version2>] }
            }

                }
            }
        }
    }
    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 <completerLine>] }
                completer { return [DisplayHints <line>] }
                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} {
    switch -- $pos {
        1 { return [DisplayHints <script>] }

    return ""
}

# -------------------------------------
#                  TK
# -------------------------------------

# generic widget configuration
# GENERIC WIDGET CONFIGURATION

proc TrySubCmds {cmd} {
proc WidgetChildren {pattern} {
    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}]
    regsub {^([^\.])} ${pattern} {\.\1} pattern
    if {![string length ${pattern}]} {
            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}
                }

            }
        set pattern .
    }
        } 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} {
    regsub {^([^\.])} ${pattern} {\.\1} pattern
    if {[winfo exists ${pattern}]} {
        return [winfo children ${pattern}]
    } else {
        regsub {.[^.]*$} $pattern {} pattern
        if {[winfo exists ${pattern}]} {
            return [winfo children ${pattern}]
        } 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]

    # first we build an option table
    #
    if {[catch [list set option_table [${widget} configure]] msg]} {
        return ""
    }
    foreach optline ${option_table} {
        if {5 != [llength ${optline}]} continue else {
            lappend options(switches) [lindex ${optline} 0]
            lappend options(value)    [lindex ${optline} 4]
        }
    }

    switch -- $pos {
    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)]
        }
    }
        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]
    switch -- $pos {
    if {1 >= ${pos}} {
        set cmds [TrySubCmds winfo]
        if {[llength ${cmds}]} {
            return [TryFromList ${mod} ${cmds}]
        }
    } elseif {2 == ${pos}} {
        return [TryFromList ${mod} [WidgetList ${mod}]]
        1 {
            set cmds [TrySubCmds winfo]
            if {[llength ${cmds}]} {
                return [TryFromList ${text} ${cmds}]
            }
        }
        2 {
            return [TryFromList ${text} [WidgetChildren ${text}]]
        }
    }
    return ""
}

}; # namespace tclreadline