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
}
}
|
