tclsh is a shell containing the TCL commands.
The TCL uplevel command evaluates the given TCL script, but it fails to evaluate a tclsh script (which can contain bash commands).
How can I obtain an analogue of uplevel for the tclsh script?
Consider this TCL script:
# 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 }
This is a kind of TCL shell, so when you type tclsh main.tcl it shows a prompt MyShell > and it acts like you are in interactive tclsh session. However, you are in non-interactive tclsh session, and everything you type is evaluated by the uplevel command. So here you can’t use bash commands like you can do it int interactive tclsh session. E.g. you can’t open vim right from the shell, also exec vim will not work.
What I want is to make MyShell > act like interactive tclsh session. The reason why I can’t just use tclsh is the loop at the last line of main.tcl: I have to have that loop and everything has to happen in that loop. I also have to do some stuff at each iteration of that loop, so can use vwait.
Here is the solution.
I have found no better solution then to overwrite the ::unknown function.
# 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 }
The idea is to modify the ::unknown function so that it handles MyShell evaluations as the ones of tclsh interactive session.
This is an ugly solution, as I am fixing the code of ::unknown function which can be different for different systems and diferent versions of tcl.
Is there any solution which circumvents these issues?
The simplest answer, I think, would be to use the approach you’re using; to rewrite the
unknowncommand. Specifically, there is a line in it that checks to make sure the current context isIf you replace that line:
with something that just checks the level
you should get what you want.