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