# FILE: tclreadlineSetup.tcl.in
# $Id$
# ---
# tclreadline -- gnu readline for tcl
# http://www.zellner.org/tclreadline/
# Copyright (c) 1998 - 2014, Johannes Zellner <johannes@zellner.org>
# This software is copyright under the BSD license.
# ---
package provide tclreadline @VERSION@
rename unknown _unknown
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
}
}
}
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
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 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 {"" == [info procs ::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;31mtclsh$tcl_version\[0m"
} elseif {[string match wish* $base] && [info exists tk_version]} {
set prompt_string "\[0;34mwish$tk_version\[0m"
} else {
set prompt_string "\[0;31m$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 ::tclreadline::prompt2] && [info nameofexecutable] != ""} {
if {"" == [info procs ::tclreadline::prompt2]} {
proc ::tclreadline::prompt2 {} {
return "> "
}
}
}
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
}
# this call is ignored, if tclreadline.c
# was compiled with CLEANUP_AFER_SIGNAL
# not defined. This is the case for
# older versions of libreadline.
#
::tclreadline::readline reset-terminal
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
}
# obsolete
#
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 {[catch {
set prompt "% "
if {"" != [info procs ::tclreadline::prompt1]} {
set prompt [::tclreadline::prompt1]
}
set ::tclreadline::LINE [::tclreadline::readline read $prompt]
while {![::tclreadline::readline complete $::tclreadline::LINE]} {
append ::tclreadline::LINE "\n"
set prompt2 "> "
if {"" != [info procs ::tclreadline::prompt2]} {
set prompt2 [::tclreadline::prompt2]
}
append ::tclreadline::LINE [tclreadline::readline read $prompt2]
}
} ::tclreadline::errorMsg]} {
puts stderr "tclreadline::Loop: error. $::tclreadline::errorMsg"
continue
}
# Magnus Eriksson <magnus.eriksson@netinsight.se> proposed
# to add the line also to tclsh's history.
#
# I decided to add only lines which are different from
# the previous one to the history. This is different
# from tcsh's behaviour, but I found it quite convenient
# while using mshell on os9.
#
if {[string length $::tclreadline::LINE]
&& [history event 0] != $::tclreadline::LINE} {
history add $::tclreadline::LINE
}
if {[catch {
set ::tclreadline::result [eval $::tclreadline::LINE]
if {$::tclreadline::result != "" && [tclreadline::Print]} {
puts $::tclreadline::result
}
set ::tclreadline::result ""
} ::tclreadline::errorMsg]} {
puts stderr $::tclreadline::errorMsg
puts stderr "while evaluating $::tclreadline::LINE"
}
}
}
}
proc Print {args} {
variable PRINT
if {![info exists PRINT]} {
set PRINT yes
}
catch {set PRINT [expr {$args ? "yes" : "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