tclreadlineSetup.tcl.in at [ad8b77b1ed]
Not logged in

File tclreadlineSetup.tcl.in artifact 602286f12e part of check-in ad8b77b1ed


#!/usr/locanl/bin/tclsh
# FILE: "/diska/home/joze/src/tclreadline/tclreadlineSetup.tcl.in"
# LAST MODIFICATION: "Wed Sep  8 18:09:57 1999 (joze)"
# (C) 1998, 1999 by Johannes Zellner, <johannes@zellner.org>
# $Id$
# ---
#
# tclreadline -- gnu readline for tcl
# Copyright (C) 1999  Johannes Zellner
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
#
# johannes@zellner.org
# http://www.zellner.org/tclreadline/
#
# ================================================================== 


package provide tclreadline @TCLREADLINE_VERSION@

proc unknown args {

    global auto_noexec auto_noload env unknown_pending tcl_interactive
    global errorCode errorInfo

    # Save the values of errorCode and errorInfo variables, since they
    # may get modified if caught errors occur below.  The variables will
    # be restored just before re-executing the missing command.

    set savedErrorCode $errorCode
    set savedErrorInfo $errorInfo
    set name [lindex $args 0]
    if ![info exists auto_noload] {
        #
        # Make sure we're not trying to load the same proc twice.
        #
        if [info exists unknown_pending($name)] {
            return -code error "self-referential recursion in \"unknown\" for command \"$name\""
        }
        set unknown_pending($name) pending
        set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
        unset unknown_pending($name)
        if {$ret != 0} {
            return -code $ret -errorcode $errorCode \
                "error while autoloading \"$name\": $msg"
        }
        if ![array size unknown_pending] {
            unset unknown_pending
        }
        if $msg {
            set errorCode $savedErrorCode
            set errorInfo $savedErrorInfo
            set code [catch {uplevel 1 $args} msg]
            if {$code ==  1} {
                #
                # Strip the last five lines off the error stack (they're
                # from the "uplevel" command).
                #

                set new [split $errorInfo \n]
                set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
                return -code error -errorcode $errorCode \
                        -errorinfo $new $msg
            } else {
                return -code $code $msg
            }
        }
    }

    # REMOVED THE [info script] TEST (joze, SEP 98)
    if {([info level] == 1) \
            && [info exists tcl_interactive] && $tcl_interactive} {
        if ![info exists auto_noexec] {
            set new [auto_execok $name]
            if {$new != ""} {
                set errorCode $savedErrorCode
                set errorInfo $savedErrorInfo
                set redir ""
                if {[info commands console] == ""} {
                    set redir ">&@stdout <@stdin"
                }
                # LOOK FOR GLOB STUFF IN $ARGS (joze, SEP 98)
                return [uplevel eval exec $redir $new \
                    [::tclreadline::Glob [lrange $args 1 end]]]
            }
        }
        set errorCode $savedErrorCode
        set errorInfo $savedErrorInfo
        if {$name == "!!"} {
            set newcmd [history event]
        } elseif {[regexp {^!(.+)$} $name dummy event]} {
            set newcmd [history event $event]
        } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
            set newcmd [history event -1]
            catch {regsub -all -- $old $newcmd $new newcmd}
        }
        if [info exists newcmd] {
            tclLog $newcmd
            history change $newcmd 0
            return [uplevel $newcmd]
        }

        set ret [catch {set cmds [info commands $name*]} msg]
        if {[string compare $name "::"] == 0} {
            set name ""
        }
        if {$ret != 0} {
            return -code $ret -errorcode $errorCode \
                "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
        }
        if {[llength $cmds] == 1} {
            return [uplevel [lreplace $args 0 0 $cmds]]
        }
        if {[llength $cmds] != 0} {
            if {$name == ""} {
                return -code error "empty command name \"\""
            } else {
                return -code error \
                        "ambiguous command name \"$name\": [lsort $cmds]"
            }
        }
    }
    return -code error "invalid command name \"$name\""
}

namespace eval tclreadline {

namespace export Setup Glob Loop InitTclCmds InitTkCmds Print ls

proc ls {args} {
    if {[exec uname -s] == "Linux"} {
        eval exec ls --color -FC [Glob $args]
    } else {
        eval exec ls -FC [Glob $args]
    }
}

proc Setup {args} {

    uplevel #0 {

        if {"" == [info commands ::tclreadline::readline]} {
            ::tclreadline::Init
        }

        if {[catch {set a [::tclreadline::prompt1]}] \
            && [info nameofexecutable] != ""} {

            namespace eval ::tclreadline {
                variable prompt_string
                set base [file tail [info nameofexecutable]]

                if {[string match tclsh* $base] && [info exists tcl_version]} {
                    set prompt_string \
                        "\[0;91mtclsh$tcl_version\[0m"
                } elseif {[string match wish* $base] \
                    && [info exists tk_version]} {
                    set prompt_string "\[0;94mwish$tk_version\[0m"
                } else {
                    set prompt_string "\[0;91m$base\[0m"
                }

            }

            if {"" == [info procs ::tclreadline::prompt1]} {
                proc ::tclreadline::prompt1 {} {
                    variable prompt_string
                    global env
                    if {[catch {set pwd [pwd]} tmp]} {
                        set pwd "unable to get pwd"
                    }

                    if [info exists env(HOME)] {
                        regsub $env(HOME) $pwd "~" pwd
                    }
                    return "$prompt_string \[$pwd\]"
                }
            }
            # puts body=[info body ::tclreadline::prompt1]
        }

        if {"" == [info procs exit]} {

            catch {rename ::tclreadline::Exit ""}
            rename exit ::tclreadline::Exit

            proc exit {args} {

                if {[catch {
                    ::tclreadline::readline write \
                    [::tclreadline::HistoryFileGet]
                } ::tclreadline::errorMsg]} {
                    puts stderr $::tclreadline::errorMsg
                }

                if [catch "eval ::tclreadline::Exit $args" message] {
                    puts stderr "error:"
                    puts stderr "$message"
                }
                # NOTREACHED
            }
        }

    }

    global env
    variable historyfile

    if {[string trim [llength ${args}]]} {
        set historyfile ""
        catch {
            set historyfile [file nativename [lindex ${args} 0]]
        }
        if {"" == [string trim $historyfile]} {
            set historyfile [lindex ${args} 0]
        }
    } else {
        if [info exists env(HOME)] {
            set historyfile  $env(HOME)/.tclsh-history
        } else {
            set historyfile  .tclsh-history
        }
    }
    set ::tclreadline::errorMsg [readline initialize $historyfile]
    if {$::tclreadline::errorMsg != ""} {
        puts stderr $::tclreadline::errorMsg
    }

    # InitCmds

    rename Setup ""
}

proc HistoryFileGet {} {
    variable historyfile
    return $historyfile
}

proc Glob {string} {

    set commandstring ""
    foreach name $string {
        set replace [glob -nocomplain -- $name]
        if {$replace == ""} {
            lappend commandstring $name
        } else {
            lappend commandstring $replace
        }
    }
    # return $commandstring
    # Christian Krone <krischan@sql.de> proposed
    return [eval concat $commandstring]
}



proc Loop {args} {

    eval Setup ${args}

    uplevel #0 {

        while {1} {

            if [info exists tcl_prompt2] {
                set prompt2 $tcl_prompt2
            } else {
                set prompt2 ">"
            }

            if {[catch {
                if {"" != [namespace eval ::tclreadline {info procs prompt1}]} {
                    set LINE [::tclreadline::readline read \
                    [::tclreadline::prompt1]]
                } else {
                    set LINE [::tclreadline::readline read %]
                }
                while {![::tclreadline::readline complete $LINE]} {
                    append LINE "\n"
                    append LINE [tclreadline::readline read ${prompt2}]
                }
            } ::tclreadline::errorMsg]} {
                puts stderr [list tclreadline::Loop: error. \
                $::tclreadline::errorMsg]
                continue
            }

            # Magnus Eriksson <magnus.eriksson@netinsight.se> proposed
            history add $LINE

            if [catch {
                set result [eval $LINE]
                if {$result != "" && [tclreadline::Print]} {
                    puts $result
                }
                set result ""
            } ::tclreadline::errorMsg] {
                puts stderr $::tclreadline::errorMsg
                puts stderr [list while evaluating $LINE]
            }

        }
    }
}

proc Print {args} {
    variable PRINT
    if ![info exists PRINT] {
        set PRINT yes
    }
    if [regexp -nocase \(true\|yes\|1\) $args] {
        set PRINT yes
    } elseif [regexp -nocase \(false\|no\|0\) $args] {
        set PRINT no
    }
    return $PRINT
}
# 
# 
# proc InitCmds {} {
#     # XXX
#     return 
#     # XXX
#     global tcl_version tk_version
#     if {[info exists tcl_version]} {
#         InitTclCmds
#     }
#     if {[info exists tk_version]} {
#         InitTkCmds
#     }
#     rename InitCmds ""
# }
# 
# proc InitTclCmds {} {
#     variable known_cmds
#     foreach line {
#         "after option ?arg arg ...?"
#         "append varName ?value value ...?"
#         "array option arrayName ?arg ...?"
#         "bgerror"
#         "break"
#         "catch command ?varName?"
#         "cd"
#         "clock"
#         "close <channelId>"
#         "concat"
#         "continue"
#         "eof <channelId>"
#         "error message ?errorInfo? ?errorCode?"
#         "eval arg ?arg ...?"
#         "exec ?switches? arg ?arg ...?"
#         "exit ?returnCode?"
#         "fblocked <channelId>"
#         "for start test next command"
#         "foreach varList list ?varList list ...? command"
#         "format formatString ?arg arg ...?"
#         "gets channelId ?varName?"
#         "glob"
#         "global varName ?varName ...?"
#         "incr varName ?increment?"
#         "info option ?arg arg ...?"
#         "interp cmd ?arg ...?"
#         "join list ?joinString?"
#         "lappend varName ?value value ...?"
#         "lindex list index"
#         "linsert list <index> <element> ?element ...?"
#         "list"
#         "llength list"
#         "lrange list first last"
#         "lreplace list first last ?element element ...?"
#         "lsearch ?mode? list pattern"
#         "lsort ?options? list"
#         "namespace"
#         "package option ?arg arg ...?"
#         "proc name args body"
#         "read ?-nonewline? channelId"
#         "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"
#         "rename oldName newName"
#         "scan <string> <format> ?varName varName ...?"
#         "set varName ?newValue?"
#         "split <string> ?splitChars?"
#         "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"
#         "switch ?switches? string pattern body ... ?default body?"
#         "time <command> ?count?"
#         "unknown <cmdName> ?arg? ?...?"
#         "uplevel ?level? command ?arg ...?"
#         "vwait name"
#         "while test command"
#     } {
#         readline add $line
#         set known_cmds([lindex $line 0]) ${line}
#     }
#     rename InitTclCmds ""
# }
# 
# proc InitTkCmds {} {
#     variable known_cmds
#     foreach line {
#         "bind window ?pattern? ?command?"
#         "bindtags window ?tags?"
#         "button pathName ?options?"
#         "canvas pathName ?options?"
#         "checkbutton pathName ?options?"
#         "clipboard option ?arg arg ...?"
#         "entry pathName ?options?"
#         "event option ?arg1?"
#         "font option ?arg?"
#         "frame pathName ?options?"
#         "grab option ?arg arg ...?"
#         "grid option arg ?arg ...?"
#         "image option ?args?"
#         "label pathName ?options?"
#         "listbox pathName ?options?"
#         "lower window ?belowThis?"
#         "menu pathName ?options?"
#         "menubutton pathName ?options?"
#         "message pathName ?options?"
#         "option cmd arg ?arg ...?"
#         "pack option arg ?arg ...?"
#         "radiobutton pathName ?options?"
#         "raise window ?aboveThis?"
#         "scale pathName ?options?"
#         "scrollbar pathName ?options?"
#         "selection option ?arg arg ...?"
#         "send ?options? interpName arg ?arg ...?"
#         "text pathName ?options?"
#         "tk option ?arg?"
#         "tkwait variable|visibility|window name"
#         "toplevel pathName ?options?"
#         "winfo option ?arg?"
#         "wm option window ?arg ...?"
#     } {
#         readline add $line
#         set known_cmds([lindex $line 0]) ${line}
#     }
#     rename InitTkCmds ""
# }
# 


}; # namespace tclreadline