Updated 2018-08-16 07:05:12 by AMG ▲

AMG: Here is a Tcl 8.5-compatible implementation of tcl::prefix that passes the 8.6.8 test suite. It uses throw, so also use forward-compatible try and throw to make it actually work in 8.5.
proc tcl::prefix {subcommand args} {
    switch $subcommand {
    a - al - all {
        # Process arguments.
        if {[llength $args] != 2} {
            throw {TCL WRONGARGS} "wrong # args: should be\
                    \"tcl::prefix all table string\""
        }
        lassign $args table string

        # Return list of all strings with the given prefix.
        lsearch -all -inline $table [regsub -all {[][?*\\]} $string {\\&}]*
    } l - lo - lon - long - longe - longes - longest {
        # Process arguments.
        if {[llength $args] != 2} {
            throw {TCL WRONGARGS} "wrong # args: should be\
                    \"tcl::prefix longest table string\""
        }
        lassign $args table string

        # Search for the longest common prefix.
        foreach entry $table {
            if {[string equal -length [string length $string] $entry $string]} {
                if {![info exists common]} {
                    set common $entry
                } else {
                    for {set i 0} {$i < [string length $common]
                                && $i < [string length $entry]} {incr i} {
                        if {[string index $common $i]
                         ne [string index $entry $i]} {
                            break
                        }
                    }
                    set common [string range $common 0 [expr {$i - 1}]]
                }
            }
        }

        # Return the longest common prefix, or empty string if no matches.
        if {[info exists common]} {
            return $common
        }
    } m - ma - mat - matc - match {
        # Process arguments.
        if {[llength $args] < 2} {
            throw {TCL WRONGARGS} "wrong # args: should be\
                    \"tcl::prefix match ?options? table string\""
        }
        lassign [lrange $args end-1 end] table string
        set args [lrange $args 0 end-2]
        set message option
        while {[llength $args]} {
            set args [lassign $args arg]
            switch $arg {
            -ex - -exa - -exac - -exact {
                # -exact switch.
                set exact {}
            } -m - -me - -mes - -mess - -messa - -messag - -message {
                # -message switch.  Next argument is the message string.
                if {![llength $args]} {
                    throw {TCL OPERATION NOARG} "missing value for -message"
                }
                set args [lassign $args message]
            } -er - -err - -erro - -error {
                # -error switch.  Next argument is the error options dict.
                if {![llength $args]} {
                    throw {TCL OPERATION NOARG} "missing value for -error"
                }
                set args [lassign $args options]
                if {[llength $options] & 1} {
                    throw {TCL VALUE DICTIONARY} "error options must have an\
                            even number of elements"
                }
            } -e {
                # Ambiguous switch.
                throw [list TCL LOOKUP INDEX option $arg] "ambiguous option\
                        \"$arg\": must be -error, -exact, or -message"
            } default {
                # Invalid switch.
                throw [list TCL LOOKUP INDEX option $arg] "bad option\
                        \"$arg\": must be -error, -exact, or -message"
            }}
        }

        # Always accept exact match, no questions asked, even if it happens to
        # also be the prefix for another string in the table.
        if {$string in $table} {
            return $string
        }

        # Attempt prefix matching unless -exact was used.  Accept a prefix match
        # if unambiguous.
        if {![info exists exact]} {
            set matches [prefix all $table $string]
            if {[llength $matches] == 1} {
                return [lindex $matches 0]
            }
        }

        # Match failed.  Assemble and return the error result.
        if {![info exists exact] && [llength $matches]} {
            set message "ambiguous $message \"$string\": "
        } else {
            set message "bad $message \"$string\": "
        }
        if {![llength $table]} {
            append message "no valid options"
        } else {
            if {[llength $table] > 1} {
                lset table end "or [lindex $table end]"
            }
            append message "must be [join $table\
                    {*}[if {[llength $table] > 2} {list ", "}]]"
        }
        if {![info exists options]} {
            set options [list -level 0 -code error\
                    -errorcode [list TCL LOOKUP INDEX $message $string]]
        }
        if {![dict size $options]} {
            set message {}
        } elseif {![dict exists $options -code]} {
            dict set options -code error
        }
        dict incr options -level
        return {*}$options $message
    } default {
        # Invalid subcommand.
        throw [list TCL LOOKUP SUBCOMMAND $arg] "unknown or ambiguous\
                subcommand \"$arg\": must be all, longest, or match"
    }}
}

Category Command