#!/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