diff options
Diffstat (limited to 'tcllib/modules/try/try.tcl')
| -rw-r--r-- | tcllib/modules/try/try.tcl | 205 |
1 files changed, 205 insertions, 0 deletions
diff --git a/tcllib/modules/try/try.tcl b/tcllib/modules/try/try.tcl new file mode 100644 index 0000000..3119587 --- /dev/null +++ b/tcllib/modules/try/try.tcl @@ -0,0 +1,205 @@ +# # ## ### ##### ######## ############# #################### +## -*- tcl -*- +## (C) 2008-2011 Donal K. Fellows, Andreas Kupries, BSD licensed. + +# The code here is a forward-compatibility implementation of Tcl 8.6's +# try/finally command (TIP 329), for Tcl 8.5. It was directly pulled +# from Tcl 8.6 revision ?, when try/finally was implemented as Tcl +# procedure instead of in C. + +# It makes use of the following Tcl 8.5 features: +# lassign, dict, {*}. + +# # ## ### ##### ######## ############# #################### + +package provide try 1 +package require Tcl 8.5 +# Do nothing if the "try" command exists already (8.6 and higher). +if {[llength [info commands try]]} return + +# # ## ### ##### ######## ############# #################### + +namespace eval ::tcl::control { + # These are not local, since this allows us to [uplevel] a [catch] rather + # than [catch] the [uplevel]ing of something, resulting in a cleaner + # -errorinfo: + variable em {} + variable opts {} + + variable magicCodes { ok 0 error 1 return 2 break 3 continue 4 } + + namespace export try + + # ::tcl::control::try -- + # + # Advanced error handling construct. + # + # Arguments: + # See try(n) for details + proc try {args} { + variable magicCodes + + # ----- Parse arguments ----- + + set trybody [lindex $args 0] + set finallybody {} + set handlers [list] + set i 1 + + while {$i < [llength $args]} { + switch -- [lindex $args $i] { + "on" { + incr i + set code [lindex $args $i] + if {[dict exists $magicCodes $code]} { + set code [dict get $magicCodes $code] + } elseif {![string is integer -strict $code]} { + set msgPart [join [dict keys $magicCodes] {", "}] + error "bad code '[lindex $args $i]': must be\ + integer or \"$msgPart\"" + } + lappend handlers [lrange $args $i $i] \ + [format %d $code] {} {*}[lrange $args $i+1 $i+2] + incr i 3 + } + "trap" { + incr i + if {![string is list [lindex $args $i]]} { + error "bad prefix '[lindex $args $i]':\ + must be a list" + } + lappend handlers [lrange $args $i $i] 1 \ + {*}[lrange $args $i $i+2] + incr i 3 + } + "finally" { + incr i + set finallybody [lindex $args $i] + incr i + break + } + default { + error "bad handler '[lindex $args $i]': must be\ + \"on code varlist body\", or\ + \"trap prefix varlist body\"" + } + } + } + + if {($i != [llength $args]) || ([lindex $handlers end] eq "-")} { + error "wrong # args: should be\ + \"try body ?handler ...? ?finally body?\"" + } + + # ----- Execute 'try' body ----- + + variable em + variable opts + set EMVAR [namespace which -variable em] + set OPTVAR [namespace which -variable opts] + set code [uplevel 1 [list ::catch $trybody $EMVAR $OPTVAR]] + + if {$code == 1} { + set line [dict get $opts -errorline] + dict append opts -errorinfo \ + "\n (\"[lindex [info level 0] 0]\" body line $line)" + } + + # Keep track of the original error message & options + set _em $em + set _opts $opts + + # ----- Find and execute handler ----- + + set errorcode {} + if {[dict exists $opts -errorcode]} { + set errorcode [dict get $opts -errorcode] + } + set found false + foreach {descrip oncode pattern varlist body} $handlers { + if {!$found} { + if { + ($code != $oncode) || ([lrange $pattern 0 end] ne + [lrange $errorcode 0 [llength $pattern]-1] ) + } then { + continue + } + } + set found true + if {$body eq "-"} { + continue + } + + # Handler found ... + + # Assign trybody results into variables + lassign $varlist resultsVarName optionsVarName + if {[llength $varlist] >= 1} { + upvar 1 $resultsVarName resultsvar + set resultsvar $em + } + if {[llength $varlist] >= 2} { + upvar 1 $optionsVarName optsvar + set optsvar $opts + } + + # Execute the handler + set code [uplevel 1 [list ::catch $body $EMVAR $OPTVAR]] + + if {$code == 1} { + set line [dict get $opts -errorline] + dict append opts -errorinfo \ + "\n (\"[lindex [info level 0] 0] ... $descrip\"\ + body line $line)" + # On error chain to original outcome + dict set opts -during $_opts + } + + # Handler result replaces the original result (whether success or + # failure); capture context of original exception for reference. + set _em $em + set _opts $opts + + # Handler has been executed - stop looking for more + break + } + + # No catch handler found -- error falls through to caller + # OR catch handler executed -- result falls through to caller + + # ----- If we have a finally block then execute it ----- + + if {$finallybody ne {}} { + set code [uplevel 1 [list ::catch $finallybody $EMVAR $OPTVAR]] + + # Finally result takes precedence except on success + + if {$code == 1} { + set line [dict get $opts -errorline] + dict append opts -errorinfo \ + "\n (\"[lindex [info level 0] 0] ... finally\"\ + body line $line)" + # On error chain to original outcome + dict set opts -during $_opts + } + if {$code != 0} { + set _em $em + set _opts $opts + } + + # Otherwise our result is not affected + } + + # Propagate the error or the result of the executed catch body to the + # caller. + dict incr _opts -level + return -options $_opts $_em + } +} + +# # ## ### ##### ######## ############# #################### + +namespace import ::tcl::control::try + +# # ## ### ##### ######## ############# #################### +## Ready |