try ... catch ... finally (Tcl recipe) by Donal Fellows

ActiveState Code (http://code.activestate.com/recipes/68396/)

namespace eval ::try {
   namespace export try
   variable bodyMatch {    \("uplevel" body line}; # Note: must be FOUR spaces
   variable usage {unknown keyword "%s" to try: should be "try body ?catch matcher body ...? ?finally body?"}

   # Some code that is factorised out.  It runs the given script in the context of our
   # caller's caller and, if that call generates an error, removes the extra junk inserted
   # into the error trace due to this.  All results are passed back by setting variables
   # in our caller's context...
   # The part argument gives the part of the error trace to insert into the error trace
   # in the case of an error occurring so as to indicate what the context of the error
   # w.r.t. the try command really is.
   proc helper {script part {eiv ei} {ecv ec} {codev code} {msgv msg}} {
      global errorInfo errorCode
      variable bodyMatch
      upvar 1 $eiv ei $ecv ec $codev code $msgv msg
      set code [catch [list uplevel 2 $script] msg]; # Note: unusual uplevel parameter
      set ec $errorCode
      set lines [split $errorInfo "\n"]
      if {$code == 1} {
         while {![regexp $bodyMatch [lindex $lines end]]} {
            set lines [lrange $lines 0 [expr {[llength $lines]-2}]]
         }
         regsub {"uplevel" body} [lindex $lines end] $part fixed
         set lines [lrange $lines 0 [expr {[llength $lines]-2}]]
         lappend lines $fixed
      }
      set ei [join $lines "\n"]
   }

   # The main command's implementation (see example for syntax.)
   proc try {body args} {

      # First, parse apart the args.  This is relatively straight-forward
      set hasFinally 0
      set catches {}
      for {set i 0} {$i<[llength $args]} {incr i} {
         set word [lindex $args $i]
         if {![string compare $word catch]} {
            if {$i+1 >= [llength $args]} {
               return -code error "missing matcher to catch"
            } elseif {$i+2 >= [llength $args]} {
               return -code error "missing body to catch"
            }
            lappend catches [lindex $args [incr i]]
            lappend catches [lindex $args [incr i]]
         } elseif {![string compare $word finally]} {
            if {$i+1 >= [llength $args]} {
               return -code error "missing body to finally"
            }
            set finally [lindex $args [incr i]]
            set hasFinally 1
         } else {
            variable usage
            return -code error [format $usage $word]
         }
      }

      # Now evaluate the body.  This updates variables "code", "ei", "ec" and "msg"
      # with the result code, the error trace, the error detail and the returned value
      # respectively...
      helper $body "try body"

      # Handle errors, if there were any.  Note that if an error does occur and gets
      # handled, the details of what the error was are lost as part of the processing.
      # Doing something more sophisticated is left as an exercise to the reader...
      if {$code == 1} {
         foreach {matcher handler} $catches {
            if {[string match $matcher $ec]} {
               helper $handler "catch \"$matcher\" body"
               break
            }
         }
      }

      # Do the finally clause.  This only wipes out the result information if the clause
      # causes an error.  Otherwise, the clause has no effect.  In particular, you cannot
      # (successfully) use return, break or continue in a finally clause.
      if {$hasFinally} {
         helper $finally "finally clause" a b c d
         if {$c} {
            set ei $a
            set ec $b
            set code $c
            set msg $d
         }
      }

      # Now we can return.  Phew!
      return -code $code -errorinfo $ei -errorcode $ec $msg
   }
}

namespace import ::try::try