tclsh是一个包含 TCL 命令的 shell。
TCLuplevel命令评估给定的 TCL 脚本，但它无法评估 tclsh 脚本（可以包含 bash 命令）。
如何获得upleveltclsh 脚本的类似物？
考虑这个 TCL 脚本：
# file main.tcl
proc prompt { } \
{
puts -nonewline stdout "MyShell > "
flush stdout
}
proc process { } \
{
catch { uplevel #0 [gets stdin] } got
if { $got ne "" } {
puts stderr $got
flush stderr
}
prompt
}
fileevent stdin readable process
prompt
while { true } { update; after 100 }
这是一种 TCL shell，所以当你键入tclsh main.tcl它时会显示一个提示MyShell >，它就像你在交互式 tclsh会话中一样。但是，您处于非交互式 tclsh会话中，并且您键入的所有内容都由uplevel命令评估。所以在这里你不能像在交互式tclsh 会话中那样使用 bash 命令。例如，您不能vim直接从外壳打开，也exec vim无法正常工作。
我想要的是使MyShell >行为像交互式tclsh会话。我不能只使用的原因tclsh是最后一行的循环main.tcl：我必须有那个循环，一切都必须在那个循环中发生。我还必须在该循环的每次迭代中做一些事情，所以可以使用vwait.
这是解决方案。
我没有找到更好的解决方案来覆盖该::unknown功能。
# file main.tcl
proc ::unknown { args } \
{
variable ::tcl::UnknownPending
global auto_noexec auto_noload env tcl_interactive
global myshell_evaluation
if { [info exists myshell_evaluation] && $myshell_evaluation } {
set level #0
} else {
set level 1
}
# If the command word has the form "namespace inscope ns cmd"
# then concatenate its arguments onto the end and evaluate it.
set cmd [lindex $args 0]
if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
#return -code error "You need an {*}"
set arglist [lrange $args 1 end]
set ret [catch {uplevel $level ::$cmd $arglist} result opts]
dict unset opts -errorinfo
dict incr opts -level
return -options $opts $result
}
catch {set savedErrorInfo $::errorInfo}
catch {set savedErrorCode $::errorCode}
set name $cmd
if {![info exists auto_noload]} {
#
# Make sure we're not trying to load the same proc twice.
#
if {[info exists UnknownPending($name)]} {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set UnknownPending($name) pending;
set ret [catch {
auto_load $name [uplevel $level {::namespace current}]
} msg opts]
unset UnknownPending($name);
if {$ret != 0} {
dict append opts -errorinfo "\n (autoloading \"$name\")"
return -options $opts $msg
}
if {![array size UnknownPending]} {
unset UnknownPending
}
if {$msg} {
if {[info exists savedErrorCode]} {
set ::errorCode $savedErrorCode
} else {
unset -nocomplain ::errorCode
}
if {[info exists savedErrorInfo]} {
set ::errorInfo $savedErrorInfo
} else {
unset -nocomplain ::errorInfo
}
set code [catch {uplevel $level $args} msg opts]
if {$code == 1} {
#
# Compute stack trace contribution from the [uplevel].
# Note the dependence on how Tcl_AddErrorInfo, etc.
# construct the stack trace.
#
set errorInfo [dict get $opts -errorinfo]
set errorCode [dict get $opts -errorcode]
set cinfo $args
if {[string bytelength $cinfo] > 150} {
set cinfo [string range $cinfo 0 150]
while {[string bytelength $cinfo] > 150} {
set cinfo [string range $cinfo 0 end-1]
}
append cinfo ...
}
append cinfo "\"\n (\"uplevel\" body line 1)"
append cinfo "\n invoked from within"
append cinfo "\n\"uplevel $level \$args\""
#
# Try each possible form of the stack trace
# and trim the extra contribution from the matching case
#
set expect "$msg\n while executing\n\"$cinfo"
if {$errorInfo eq $expect} {
#
# The stack has only the eval from the expanded command
# Do not generate any stack trace here.
#
dict unset opts -errorinfo
dict incr opts -level
return -options $opts $msg
}
#
# Stack trace is nested, trim off just the contribution
# from the extra "eval" of $args due to the "catch" above.
#
set expect "\n invoked from within\n\"$cinfo"
set exlen [string length $expect]
set eilen [string length $errorInfo]
set i [expr {$eilen - $exlen - 1}]
set einfo [string range $errorInfo 0 $i]
#
# For now verify that $errorInfo consists of what we are about
# to return plus what we expected to trim off.
#
if {$errorInfo ne "$einfo$expect"} {
error "Tcl bug: unexpected stack trace in \"unknown\"" {} [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo]
}
return -code error -errorcode $errorCode -errorinfo $einfo $msg
} else {
dict incr opts -level
return -options $opts $msg
}
}
}
if { ( [info exists myshell_evaluation] && $myshell_evaluation ) || (([info level] == 1) && ([info script] eq "") && [info exists tcl_interactive] && $tcl_interactive) } {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {$new ne ""} {
set redir ""
if {[namespace which -command console] eq ""} {
set redir ">&@stdout <@stdin"
}
uplevel $level [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions]
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
}
if {$name eq "!!"} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name -> event]} {
set newcmd [history event $event]
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
uplevel $level [list ::catch $newcmd ::tcl::UnknownResult ::tcl::UnknownOptions]
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
set ret [catch {set candidates [info commands $name*]} msg]
if {$name eq "::"} {
set name ""
}
if {$ret != 0} {
dict append opts -errorinfo "\n (expanding command prefix \"$name\" in unknown)"
return -options $opts $msg
}
# Filter out bogus matches when $name contained
# a glob-special char [Bug 946952]
if {$name eq ""} {
# Handle empty $name separately due to strangeness
# in [string first] (See RFE 1243354)
set cmds $candidates
} else {
set cmds [list]
foreach x $candidates {
if {[string first $name $x] == 0} {
lappend cmds $x
}
}
}
if {[llength $cmds] == 1} {
uplevel $level [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] ::tcl::UnknownResult ::tcl::UnknownOptions]
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
if {[llength $cmds]} {
return -code error "ambiguous command name \"$name\": [lsort $cmds]"
}
}
return -code error "invalid command name \"$name\""
}
proc prompt { } \
{
puts -nonewline stdout "MyShell > "
flush stdout
}
proc process { } \
{
global myshell_evaluation
set myshell_evaluation true
catch { uplevel #0 [gets stdin] } got
set myshell_evaluation false
if { $got ne "" } {
puts stderr $got
flush stderr
}
prompt
}
fileevent stdin readable process
prompt
while { true } { update; after 100 }
这个想法是修改::unknown函数，以便它处理MyShell评估作为tclsh交互式会话的评估。
这是一个丑陋的解决方案，因为我正在修复::unknown对于不同系统和不同版本的 tcl 可能不同的函数代码。
是否有任何解决方案可以规避这些问题？