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