ascaller.tcl

Go to the documentation of this file.

/*  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 ::control {

    ret  CommandAsCaller (type cmdVar , type resultVar , optional where ={) {codeVar code}} {
     x =  [expr {[string equal "" $where] 
        ? {} : [subst -nobackslashes {\n    ($where)}]}]
     script =  [subst -nobackslashes -nocommands {
         $codeVar =  [catch {uplevel 1 $$cmdVar} $resultVar]
        if {$$codeVar > 1} {
        return -code $$codeVar $$resultVar
        }
        if {$$codeVar == 1} {
        if {[string equal {"uplevel 1 $$cmdVar"} \
            [lindex [split [ ::errorInfo = ] \n] end]]} {
             $codeVar =  [join \
                [lrange [split [ ::errorInfo = ] \n] 0 \
                end-[expr {4+[llength [split $$cmdVar \n]]}]] \n]
        } else {
             $codeVar =  [join \
                [lrange [split [ ::errorInfo = ] \n] 0 end-1] \n]
        }
        return -code error -errorcode [ ::errorCode = ] \
            -errorinfo "$$codeVar$x" $$resultVar
        }
    }]
    return $script
    }

    ret  BodyAsCaller (type bodyVar , type resultVar , type codeVar , optional where ={)} {
    set x [expr {[string equal "" $where]
        ? {} : [subst -nobackslashes -nocommands \
        {\n    ($where[string map {{    ("uplevel"} {}} \
        [lindex [split [set ::errorInfo] \n] end]]}]}]
     script =  [subst -nobackslashes -nocommands {
         $codeVar =  [catch {uplevel 1 $$bodyVar} $resultVar]
        if {$$codeVar == 1} {
        if {[string equal {"uplevel 1 $$bodyVar"} \
            [lindex [split [ ::errorInfo = ] \n] end]]} {
             ::errorInfo =  [join \
                [lrange [split [ ::errorInfo = ] \n] 0 end-2] \n]
        } 
         $codeVar =  [join \
            [lrange [split [ ::errorInfo = ] \n] 0 end-1] \n]
        return -code error -errorcode [ ::errorCode = ] \
            -errorinfo "$$codeVar$x" $$resultVar
        }
    }]
    return $script
    }

    ret  ErrorInfoAsCaller (type find , type 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
    }

}