#!/usr/local/bin/tclsh
# FILE: "/diska/home/joze/src/tclreadline/tclreadlineSetup.tcl.in"
# LAST MODIFICATION: "Wed Aug 25 14:49:37 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 InitCmds InitTclCmds InitTkCmds Print ls
}
# get the longest common completion
# e.g. str == {tcl_version tclreadline_version tclreadline_library}
# --> [tclreadline::GetCommon ${str}] == "tcl"
#
proc tclreadline::GetCommon {str} {
# puts stderr str=$str
set match0 [lindex ${str} 0]
set len0 [string length $match0]
set no_matches [llength ${str}]
set part ""
for {set i 0} {$i < $len0} {incr i} {
set char [string index $match0 $i]
for {set j 1} {$j < $no_matches} {incr j} {
if {$char != [string index [lindex ${str} $j] $i]} {
break
}
}
if {$j < $no_matches} {
break
} else {
append part $char
}
}
# puts stderr part=$part
return ${part}
}
proc tclreadline::SubCmd {start line} {
set depth 0
for {set i $start} {$i > 0} {incr i -1} {
set c [string index $line $i]
if {{;} == $c} {
incr i; # discard command break character
return [list [expr $start - $i] [string range $line $i end]]
} elseif {{]} == $c} {
incr depth
} elseif {{[} == $c} {
incr depth -1
if {$depth < 0} {
incr i; # discard command break character
return [list [expr $start - $i] [string range $line $i end]]
}
}
}
return ""
}
# % p<TAB>
# % bla put<TAB> $b
# % put<TAB> $b
# part == put
# start == 0
# end == 3
# line == "put $b"
# [PartPosition] should return 0
#
proc tclreadline::PartPosition {part start end line} {
incr start -1
# puts stderr "(tclreadline::PartPosition) line=|$line|"
# puts stderr "(tclreadline::PartPosition) start=$start"
set line [string range $line 0 $start]
regsub -all -- \" $line {\"} line
# puts stderr "(tclreadline::PartPosition) line=|$line|"
set result [llength $line]
# puts stderr $result
return $result
}
# if the line entered so far is
# % puts $b<TAB>
# part == $b
# start == 5
# end == 7
# line == "$puts $b"
#
proc tclreadline::ScriptCompleter {part start end line} {
# puts stderr "(ScriptCompleter) |$part| $start $end |$line|"
variable known_cmds
if {{$} == [string index $part 0]} {
# variable completion. Check first, if the
# variable starts with a plain `$' or should
# be enclosed in braces.
#
if {"\{" == [string index $part 1]} {
set var [string range $part 2 end]
set left "\$\{"
set right "\}"
} else {
set left "\$"
set right ""
set var [string range $part 1 end]
}
# check if $var is an array name, which
# already has already a "(" somewhere inside.
#
if {[regexp {([^(]*)\((.*)} $var all array name]} {
set matches [uplevel array names ${array} ${name}*]
if {1 == [llength $matches]} { ; # unique match
return "\$${array}(${matches})"
} elseif {"" != ${matches}} {
return \
"\$${array}([tclreadline::GetCommon ${matches}] ${matches}"
} else {
return ""; # nothing to complete
}
}
set matches [uplevel info vars "${var}*"]
if {1 == [llength $matches]} { ; # unique match
# check if this unique match is an
# array name, (whith no "(" yet).
#
if {[uplevel array exists $matches]} {
return "\$${matches}( [uplevel array names $matches]"
} else {
return [join [list $left $matches $right] ""]
}
} elseif {"" != $matches} { ; # more than one matches
return "${left}[tclreadline::GetCommon ${matches}] ${matches}"
} else {
return ""; # nothing to complete
}
# SCENARIO:
#
# % puts bla; put<TAB> $b
# part == put
# start == 10
# end == 13
# line == "puts bla; put $b"
# [SubCmd] --> {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 [tclreadline::SubCmd $start $line]]} {
set new_start [lindex $sub 0]
set new_end [expr $end - ($start - $new_start)]
set new_line [lindex $sub 1]
# puts stderr "(SubCmd) $new_start $new_end $new_line"
return \
[tclreadline::ScriptCompleter $part $new_start $new_end $new_line]
} elseif {0 == [set pos [tclreadline::PartPosition $part $start $end $line]]} {
# puts stderr "(PartPosition) $part $start $end $line"
# set matches [array names known_cmds "[string trim ${part}]*"]
set cmd "[string trim ${part}]*"
set matches [string trim "[info commands $cmd] [info proc $cmd]"]
# puts matches=|$matches|
if {1 == [llength $matches]} { ; # unique match
return $matches
} elseif {"" != $matches} {
set common [tclreadline::GetCommon ${matches}]
# puts stderr common=|$common|
if {"" == $common} {
return "[list $part] ${matches}"
} else {
return "$common ${matches}"
}
} else {
return ""; # nothing to complete
}
} else {
# try to use $pos further ...
regsub -all -- \" $line {\"} thisline
set cmd [lindex $thisline 0]
if {"" != [array names known_cmds $cmd]} {
set current [lindex $known_cmds($cmd) $pos]
if {"" != $current && "" == [string trim $part]} {
return $current
} else {
return ""
}
} else {
return ""
}
}
return "{NOTREACHED (this is probably an error)}"
}
proc tclreadline::ls {args} {
if {[exec uname -s] == "Linux"} {
eval exec ls --color -FC [::tclreadline::Glob $args]
} else {
eval exec ls -FC [::tclreadline::Glob $args]
}
}
proc ::tclreadline::Setup {args} {
uplevel #0 {
if {[info commands ::tclreadline::readline] == ""} {
::tclreadline::Init
}
tclreadline::readline customcompleter tclreadline::ScriptCompleter
if {[catch {set a [::tclreadline::prompt1]}] \
&& [info nameofexecutable] != ""} {
namespace eval ::tclreadline {
variable prompt_string
set base [file tail [info nameofexecutable]]
if {$base == "tclsh" && [info exists tcl_version]} {
set prompt_string \
"\[0;91m$base$tcl_version\[0m"
} elseif {$base == "wish" && [info exists tk_version]} {
set prompt_string "\[0;94m$base$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\]"
}
}
}
if {[info procs exit] == ""} {
catch {rename ::tclreadline::Exit ""}
rename exit ::tclreadline::Exit
proc exit {args} {
catch {
::tclreadline::readline write \
[::tclreadline::HistoryFileGet]
}
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 msg [::tclreadline::readline initialize $historyfile]
if {$msg != ""} {
puts stderr "$msg"
}
::tclreadline::InitCmds
rename ::tclreadline::Setup ""
}
proc ::tclreadline::HistoryFileGet {} {
variable historyfile
return $historyfile
}
proc ::tclreadline::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 ::tclreadline::Loop {args} {
eval ::tclreadline::Setup ${args}
uplevel #0 {
while {1} {
if [info exists tcl_prompt2] {
set ::tclreadline::prompt2 $tcl_prompt2
} else {
set ::tclreadline::prompt2 ">"
}
if {[namespace eval ::tclreadline {[info procs prompt1]}] != ""} {
set ::tclreadline::LINE [::tclreadline::readline read \
[::tclreadline::prompt1]]
} else {
set ::tclreadline::LINE [::tclreadline::readline read %]
}
while {![::tclreadline::readline complete $::tclreadline::LINE]} {
append ::tclreadline::LINE "\n"
append ::tclreadline::LINE [::tclreadline::readline read \
${::tclreadline::prompt2}]
}
# Magnus Eriksson <magnus.eriksson@netinsight.se> proposed
history add $::tclreadline::LINE
if [catch {
set result [eval $::tclreadline::LINE]
if {$result != "" && [::tclreadline::Print]} {
puts $result
}
set result ""
} msg] {
puts stderr $msg
}
}
}
}
proc ::tclreadline::Print {args} {
variable PRINT
if ![info exists PRINT] {
set ::tclreadline::PRINT yes
}
if [regexp -nocase \(true\|yes\|1\) $args] {
set ::tclreadline::PRINT yes
} elseif [regexp -nocase \(false\|no\|0\) $args] {
set ::tclreadline::PRINT no
}
return $PRINT
}
proc ::tclreadline::InitCmds {} {
global tcl_version tk_version
if {[info exists tcl_version]} {
::tclreadline::InitTclCmds
}
if {[info exists tk_version]} {
::tclreadline::InitTkCmds
}
rename tclreadline::InitCmds ""
}
proc ::tclreadline::InitTclCmds {} {
variable known_cmds
foreach line {
"after option ?arg arg ...?"
"append varName ?value value ...?"
"array option arrayName ?arg ...?"
"binary option ?arg arg ...?"
"catch command ?varName?"
"clock option ?arg ...?"
"close channelId"
"eof channelId"
"error message ?errorInfo? ?errorCode?"
"eval arg ?arg ...?"
"exec ?switches? arg ?arg ...?"
"expr arg ?arg ...?"
"fblocked channelId"
"fconfigure channelId ?optionName? ?value? ?optionName value?..."
"fcopy input output ?-size size? ?-command callback?"
"file option ?arg ...?"
"fileevent channelId event ?script?"
"flush channelId"
"for start test next command"
"foreach varList list ?varList list ...? command"
"format formatString ?arg arg ...?"
"gets channelId ?varName?"
"glob ?switches? name ?name ...?"
"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 ...?"
"llength list"
"load fileName ?packageName? ?interp?"
"lrange list first last"
"lreplace list first last ?element element ...?"
"lsearch ?mode? list pattern"
"lsort ?options? list"
"namespace subcommand ?arg ...?"
"open fileName ?access? ?permissions?"
"package option ?arg arg ...?"
"proc name args body"
"puts ?-nonewline? ?channelId? string"
"read ?-nonewline? channelId"
"regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"
"regsub ?switches? exp string subSpec varName"
"rename oldName newName"
"scan string format ?varName varName ...?"
"seek channelId offset ?origin?"
"set varName ?newValue?"
"socket ?-myaddr addr? ?-myport myport? ?-async? host port"
"socket -server command ?-myaddr addr? port"
"source fileName"
"split string ?splitChars?"
"string option arg ?arg ...?"
"subst ?-nobackslashes? ?-nocommands? ?-novariables? string"
"switch ?switches? string pattern body ... ?default body?"
"tell channelId"
"time command ?count?"
"trace option \[arg arg ...\]"
"unset varName ?varName ...?"
"uplevel ?level? command ?arg ...?"
"upvar ?level? otherVar localVar ?otherVar localVar ...?"
"vwait name"
"while test command"
} {
tclreadline::readline add $line
set known_cmds([lindex $line 0]) [lrange $line 1 end]
}
rename tclreadline::InitTclCmds ""
}
proc ::tclreadline::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 ...?"
} {
tclreadline::readline add $line
set known_cmds([lindex $line 0]) [lrange $line 1 end]
}
rename tclreadline::InitTkCmds ""
}