tclsh是一个包含TCL命令的shell。
TCL uplevel命令评估给定的TCL脚本，但无法评估tclsh脚本（可以包含bash命令）。
如何为tclsh脚本获取uplevel的类似物？
考虑一下这个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命令。例如。您无法直接在shell中打开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版本可能会有所不同。
有没有解决这些问题的解决方案？
答案 0 :(得分：1)
uplevel不仅评估脚本，而且还在执行它的实例的调用者的堆栈上下文中对其进行评估。这是一个非常高级的命令，当你定义自己的执行控制结构时应该使用它，OFC它是特定于TCL的 - 我发现自己无法想象tclsh等价物应该如何工作。
如果您只想评估另一个脚本，那么正确的TCL命令就是eval。如果那个其他脚本是tclsh，你为什么不打开另一个tclsh？
答案 1 :(得分：0)
我认为最简单的答案是使用您正在使用的方法;重写unknown命令。具体来说，它中有一行检查以确保当前上下文是
如果替换该行：
if {([info level] == 1) && ([info script] eq "") && [info exists tcl_interactive] && $tcl_interactive} {
只需检查级别
if ([info level] == 1} {
你应该得到你想要的东西。
答案 2 :(得分：0)
Vaghan，你做有正确的解决方案。使用:: unknown是tclsh本身如何提供您正在讨论的交互式shell功能（调用外部二进制文件等）。而你已经解除了相同的代码并将其包含在你的MyShell中。
但是，如果我理解你担心这是一个“丑陋的解决方案”，你宁愿不重置::未知？
在这种情况下，为什么不直接将所需的附加功能附加到预先存在的:: unknown的正文的末尾（或者在它之前添加 - 你选择）
如果你在Tcl'ers维基上搜索“让我们知道”，你会看到一个简单的过程来证明这一点。它将新代码添加到现有的:: unknown中，因此您可以继续添加额外的“后备代码”。
（如果我误解了为什么你认为你的解决方案“丑陋”，那就道歉了）
答案 3 :(得分：0)
我建议您进行更改以评估表达式，而不是更改unknown过程
if {([info level] == 1) && ([info script] eq "") && [info exists tcl_interactive] && $tcl_interactive} {
为真。
info level：用uplevel #0 $code info script：致电info script {}将其设为空值tcl_interactive。简单：set ::tcl_interactive 1 所以你的代码将是
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
set tcl_interactive 1
info script {}
prompt
vwait forever