source: tol/tolbaseBLT/lib/trycatch/trycatch.tcl @ 56ade3b

#---------------------------------------------------------------------
# TITLE:
#       trycatch.tcl
#
# AUTHOR:
#       Will Duquette
#
# DESCRIPTION:
#       This package implements an exception handler control structure
#       on top of the [catch] command.  See trycatch.ehtml for user
#       documentation.
#
#       Copyright (C) 2001 by William H. Duquette.  See license.txt
#       for license information.

#---------------------------------------------------------------------
# Package definition

package provide trycatch 2.0

#---------------------------------------------------------------------
# Namespace definition

namespace eval ::trycatch:: {
    # Exported Commands
    namespace export try throw onerr
}

#---------------------------------------------------------------------
# Command definitions

#---------------------------------------------------------------------
# FUNCTION:
#       try {tryScript} 
#       try {tryScript} catch ?options? {catchScript}
#       try {tryScript} finally {finallyScript}
#
# INPUTS:
#       tryScript       Script to execute, catching errors.
#       args            catch or finally clauses
#
# OUTPUTS:
#       none
#
# RETURNS:
#       The value (and return code) of tryScript or catchScript
#
# DESCRIPTION:
#       Evaluates tryScript in the context of the caller, catching the
#       result and the return code (see [return]).  If the return code 
#       indicates no error, then try returns tryScripts result and
#       return code.  messageVar is unchanged in this case.
#
#       If tryScript fails, then catchScript is evaluated in the context of the
#       caller, and catchScript's result and return code are returned.

proc ::trycatch::try {tryScript args} {
    global errorCode errorInfo

    set usage "syntax: try {...} catch ?opts? {...}, try {...} finally {...}"
    set optionsUsage "valid options: -msg msgVar -code codeVar -info infoVar"
    

    # FIRST, if this is the trivial case, just do it.
    if {[llength $args] == 0} {
        # FIRST, evaluate the tryScript.
        set returnCode [catch {uplevel 1 $tryScript} result]
            
        # NEXT, on error return something innocuous
        if {$returnCode == 1} {
            set returnCode 0
            set result ""
        }

        # NEXT, return it.
        return -code $returnCode $result
    }

    # NEXT, do what makes sense based on the first token in args
    if {"catch" == [Next $args]} {
        # FIRST, get any option values and the catch script
        Pop args
        
        while {[string match "-*" [Next $args]]} {
            set option [Pop args]
            set var [Pop args]

            if {"" == $var} {
                error $optionsUsage
            }

            switch -- $option {
                -msg  {upvar $var theMsg}
                -code {upvar $var theCode}
                -info {upvar $var theInfo}
                default {error $optionsUsage}
            }
        }
        
        if {[llength $args] == 0} {
            error $usage
        }

        set catchScript [Pop args]

        if {[llength $args] != 0} {
            error $usage
        }

        # NEXT, execute the try script, saving its return value.
        set returnCode [catch {uplevel 1 $tryScript} result]

        # NEXT, if there was an error, execute the
        # catchScript in the context of the caller.
        if {$returnCode == 1} {
            # If the appropriate options were passed, then upvar has
            # aliased these to the user's variables.  Otherwise, they
            # are just local.
        
            set theMsg $result
            set theCode $errorCode
            set theInfo $errorInfo

            set returnCode [catch {uplevel 1 $catchScript} result]
        }

        # NEXT, return the result and result code.  If there was an error
        # we need to propagate the error information as well, so go ahead
        # and include them; they'll be ignored if there was no error.
        return -code $returnCode \
                -errorcode $errorCode -errorinfo \
                $errorInfo \
                $result
    } elseif {"finally" == [Next $args]} {
        # FIRST, validate the args, and get the finally script.
        Pop args

        if {[llength $args] != 1} {
            error $usage
        }
        set finallyScript [Pop args]

        # NEXT, evaluate the tryScript, saving its return values
        set returnCode [catch {uplevel 1 $tryScript} result]
        
        # NEXT, evaluate the finally script.  Throw an error
        # if the result is anything but "ok"
        set finallyCode [catch {uplevel 1 $finallyScript} finallyResult]

        if {$finallyCode == 1} {
            return -code $finallyCode \
                    -errorcode $errorCode -errorinfo \
                    $errorInfo \
                    $finallyResult
        } elseif {$finallyCode != 0} {
            error "break, return, or continue in finally script"
        }

        # NEXT, return the result and result code.  If there was an error
        # we need to propagate the error information as well, so go ahead
        # and include them; they'll be ignored if there was no error.
        return -code $returnCode \
                -errorcode $errorCode -errorinfo \
                $errorInfo \
                $result
    } else {
        error $usage
    }
}

#---------------------------------------------------------------------
# FUNCTION:
#       throw code message
#
# INPUTS:
#       code            An error code; it should be list.
#       message         A human-readable error message
#
# OUTPUTS:
#       none
#
# RETURNS:
#       Throws an error.
#
# DESCRIPTION:
#       Equivalent to 
#
#           error $message "" $code
#
#       It's provided for code that makes explicit use of error codes.

proc ::trycatch::throw {code message} {
    error $message "" $code
}

#---------------------------------------------------------------------
# FUNCTION:
#       onerr ?-code code? pattern script pattern script...
#
# INPUTS:
#       args            Command arguments
#
# OUTPUTS:
#       none
#
# RETURNS:
#       Return value of executed script, if any.
#
# DESCRIPTION:
#       Matches either the global errorCode or the specified code
#       against each pattern in turn (using Match) until a match is
#       found or the patterns are exhausted.  If a match is found, the
#       the matching script is executed.

proc ::trycatch::onerr {args} {
    global errorCode
    global errorInfo

    set usage "syntax: onerr ?-code errorCode? pattern script ..."

    # FIRST, see if a code has been specified; otherwise, use the
    # global errorCode.

    if {[string match "-*" [Next $args]]} {
        set opt [Pop args]
        if {"-code" != $opt || [llength $args] == 0} {
            error $usage
        }

        set code [Pop args]
    } else {
        set code $errorCode
    }

    # NEXT, match each in turn until a match is found.
    
    if {[llength $args] % 2 != 0} {
        error $usage
    }

    foreach {pattern script} $args {
        # Does it Match?
        if {[Match $pattern $code]} {
            # FIRST, execute the script
            set returnCode [catch {uplevel 1 $script} result]
            
            # NEXT, return the results.  The error data will be
            # ignored if the return code is not an error.
            
            return -code $returnCode \
                    -errorcode $errorCode -errorinfo $errorInfo \
                    $result
        }
    }

    return
}

#---------------------------------------------------------------------
# FUNCTION:
#       Next
#
# INPUTS:
#       list
#
# OUTPUTS:
#       none
#
# RETURNS:
#       Next arg in the list
#
# DESCRIPTION:
#       Returns the next arg in a list

proc ::trycatch::Next {list} {
    return [lindex $list 0]
}

#---------------------------------------------------------------------
# FUNCTION:
#       Pop
#
# INPUTS:
#       listVar
#
# OUTPUTS:
#       none
#
# RETURNS:
#       The first arg
#
# DESCRIPTION:
#       Removes the first arg from the list

proc ::trycatch::Pop {listVar} {
    upvar $listVar theList
    set result [lindex $theList 0]
    set theList [lrange $theList 1 end]

    return $result
}

#---------------------------------------------------------------------
# FUNCTION:
#       Match patternList code
#
# INPUTS:
#       patternList             A list of glob-patterns
#       code                    An errorCode value
#
# OUTPUTS:
#       none
#
# RETURNS:
#       1 or 0
#
# DESCRIPTION:
#       Matches the patterns in patternList against the tokens of
#       code.  If a pattern doesn't match, or there are more patterns than
#       tokens, the function returns 0.  Otherwise, it returns 1.

proc ::trycatch::Match {patternList code} {
    set len [llength $patternList]

    if {[llength $code] < $len} {
        return 0
    }

    for {set i 0} {$i < $len} {incr i} {
        set pattern [lindex $patternList $i]
        set token [lindex $code $i]

        if {![string match $pattern $token]} {
            return 0
        }
    }

    return 1
}