Add tcl forward-compatibility for try-finally

tcl/Extras.tcl

@@ -67,3 +67,127 @@ proc date {} {
 proc mem {} {
   return [exec ps -o rss= -p [pid]]
 }
+
+################################################################
+# TCL 8.6 forward-compatibility
+################################################################
+
+proc try {args} {
+    # Require at least one argument.
+    if {![llength $args]} {
+        throw {TCL WRONGARGS} "wrong # args: should be\
+                \"try body ?handler ...? ?finally script?\""
+    }
+
+    # Scan arguments.
+    set args [lassign $args body]
+    set handlers {}
+    while {[llength $args]} {
+        set args [lassign $args type]
+        switch $type {
+        on {
+            if {[llength $args] < 3} {
+                throw {TCL OPERATION TRY ON ARGUMENT} "wrong # args to on\
+                        clause: must be \"... on code variableList script\""
+            }
+            set args [lassign $args code variableList script]
+            if {![string is integer -strict $code]} {
+                if {[regexp {^[ \f\n\r\t\v]*[-+]?\d+[ \f\n\r\t\v]*$} $code]
+                 || [set newCode [lsearch -exact\
+                            {ok error return break continue} $code]] < 0} {
+                    throw {TCL RESULT ILLEGAL_CODE} "bad completion code\
+                            \"$code\": must be ok, error, return, break,\
+                            continue, or an integer"
+                }
+                set code $newCode
+            }
+            lappend handlers on $code $variableList $script
+        } trap {
+            if {[llength $args] < 3} {
+                throw {TCL OPERATION TRY TRAP ARGUMENT} "wrong # args to\
+                        trap clause: must be \"... trap pattern\
+                        variableList script\""
+            }
+            set args [lassign $args pattern variableList script]
+            if {[catch {list {*}$pattern} pattern]} {
+                throw {TCL OPERATION TRY TRAP EXNFORMAT} "bad prefix\
+                        '$pattern': must be a list"
+            }
+            lappend handlers trap $pattern $variableList $script
+        } finally {
+            if {![llength $args]} {
+                throw {TCL OPERATION TRY FINALLY ARGUMENT} "wrong # args\
+                        to finally clause: must be \"... finally script\""
+            }
+            set args [lassign $args finally]
+            if {[llength $args]} {
+                throw {TCL OPERATION TRY FINALLY NONTERMINAL} "finally\
+                        clause must be last"
+            }
+        } default {
+            throw [list TCL LOOKUP INDEX {handler type} $type] "bad handler\
+                    type \"$type\": must be finally, on, or trap"
+        }}
+    }
+    if {[info exists script] && $script eq "-"} {
+        throw {TCL OPERATION TRY BADFALLTHROUGH} "last non-finally clause must\
+                not have a body of \"-\""
+    }
+
+    # Evaluate the script body and intercept errors.
+    set code [catch {uplevel 1 $body} result options]
+
+    # Search for and evaluate the first matching handler.
+    foreach {type pattern varList script} $handlers {
+        if {![info exists next] && ($type ne "on" || $pattern != $code)
+         && ($type ne "trap" || ![dict exists $options -errorcode]
+          || $pattern ne [lrange [dict get $options -errorcode]\
+                0 [expr {[llength $pattern] - 1}]])} {
+            # Skip this handler if it doesn't match.
+        } elseif {$script eq "-"} {
+            # If the script is "-", evaluate the next handler script that is not
+            # "-", regardless of the match criteria.
+            set next {}
+        } else {
+            # Evaluate the handler script and intercept errors.
+            if {[catch {
+                if {[llength $varList] >= 1} {
+                    uplevel 1 [list set [lindex $varList 0] $result]
+                }
+                if {[llength $varList] >= 2} {
+                    uplevel 1 [list set [lindex $varList 1] $options]
+                }
+                uplevel 1 $script
+            } result newOptions] && [dict exists $newOptions -errorcode]} {
+                dict set newOptions -during $options
+            }
+            set options $newOptions
+
+            # Stop after evaluating the first matching handler script.
+            break
+        }
+    }
+
+    # Evaluate the finally clause and intercept errors.
+    if {[info exists finally]
+     && [catch {uplevel 1 $finally} newResult newOptions]} {
+        if {[dict exists $newOptions -errorcode]} {
+            dict set newOptions -during $options
+        }
+        set options $newOptions
+        set result $newResult
+    }
+
+    # Return any errors generated by the handler scripts.
+    dict incr options -level
+    return {*}$options $result
+}
+
+proc throw {type message} {
+    if {![llength $type]} {
+        return -code error -errorcode {TCL OPERATION THROW BADEXCEPTION}\
+                "type must be non-empty list"
+    } else {
+        return -code error -errorcode $type $message
+    }
+}