Created
March 22, 2015 05:46
-
-
Save zhengwy888/80ef66ee4746e92d75cf to your computer and use it in GitHub Desktop.
Tclsh 8.6 unknown proc implementation
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# generated from [info body unknown] in tclsh8.6, on Debian (Jessie) | |
# man page http://www.tcl.tk/man/tcl8.5/TclCmd/unknown.htm | |
variable ::tcl::UnknownPending | |
global auto_noexec auto_noload env tcl_interactive errorInfo errorCode | |
if {[info exists errorInfo]} { | |
set savedErrorInfo $errorInfo | |
} | |
if {[info exists errorCode]} { | |
set savedErrorCode $errorCode | |
} | |
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 UnknownPending($name)]} { | |
return -code error "self-referential recursion in \"unknown\" for command \"$name\"" | |
} | |
set UnknownPending($name) pending | |
set ret [catch { | |
auto_load $name [uplevel 1 {::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 1 $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 errInfo [dict get $opts -errorinfo] | |
set errCode [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 1 \$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 {$errInfo 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 $errInfo] | |
set i [expr {$eilen - $exlen - 1}] | |
set einfo [string range $errInfo 0 $i] | |
# | |
# For now verify that $errInfo consists of what we are about | |
# to return plus what we expected to trim off. | |
# | |
if {$errInfo ne "$einfo$expect"} { | |
error "Tcl bug: unexpected stack trace in \"unknown\"" {} [list CORE UNKNOWN BADTRACE $einfo $expect $errInfo] | |
} | |
return -code error -errorcode $errCode -errorinfo $einfo $msg | |
} else { | |
dict incr opts -level | |
return -options $opts $msg | |
} | |
} | |
} | |
if {([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 1 [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 1 [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 1 [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 -errorcode [list TCL LOOKUP COMMAND $name] "invalid command name \"$name\"" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment