/usr/share/tcltk/tcllib1.17/control/ascaller.tcl is in tcllib 1.17-dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | # ascaller.tcl -
#
# A few utility procs that manage the evaluation of a command
# or a script in the context of a caller, taking care of all
# the ugly details of proper return codes, errorcodes, and
# a good stack trace in ::errorInfo as appropriate.
# -------------------------------------------------------------------------
#
# RCS: @(#) $Id: ascaller.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $
namespace eval ::control {
proc CommandAsCaller {cmdVar resultVar {where {}} {codeVar code}} {
set x [expr {[string equal "" $where]
? {} : [subst -nobackslashes {\n ($where)}]}]
set script [subst -nobackslashes -nocommands {
set $codeVar [catch {uplevel 1 $$cmdVar} $resultVar]
if {$$codeVar > 1} {
return -code $$codeVar $$resultVar
}
if {$$codeVar == 1} {
if {[string equal {"uplevel 1 $$cmdVar"} \
[lindex [split [set ::errorInfo] \n] end]]} {
set $codeVar [join \
[lrange [split [set ::errorInfo] \n] 0 \
end-[expr {4+[llength [split $$cmdVar \n]]}]] \n]
} else {
set $codeVar [join \
[lrange [split [set ::errorInfo] \n] 0 end-1] \n]
}
return -code error -errorcode [set ::errorCode] \
-errorinfo "$$codeVar$x" $$resultVar
}
}]
return $script
}
proc BodyAsCaller {bodyVar resultVar codeVar {where {}}} {
set x [expr {[string equal "" $where]
? {} : [subst -nobackslashes -nocommands \
{\n ($where[string map {{ ("uplevel"} {}} \
[lindex [split [set ::errorInfo] \n] end]]}]}]
set script [subst -nobackslashes -nocommands {
set $codeVar [catch {uplevel 1 $$bodyVar} $resultVar]
if {$$codeVar == 1} {
if {[string equal {"uplevel 1 $$bodyVar"} \
[lindex [split [set ::errorInfo] \n] end]]} {
set ::errorInfo [join \
[lrange [split [set ::errorInfo] \n] 0 end-2] \n]
}
set $codeVar [join \
[lrange [split [set ::errorInfo] \n] 0 end-1] \n]
return -code error -errorcode [set ::errorCode] \
-errorinfo "$$codeVar$x" $$resultVar
}
}]
return $script
}
proc ErrorInfoAsCaller {find replace} {
set info $::errorInfo
set i [string last "\n (\"$find" $info]
if {$i == -1} {return $info}
set result [string range $info 0 [incr i 6]] ;# keep "\n (\""
append result $replace ;# $find -> $replace
incr i [string length $find]
set j [string first ) $info [incr i]] ;# keep rest of parenthetical
append result [string range $info $i $j]
return $result
}
}
|