try.tcl

# Do nothing if the try command exists already (8.6+).
if {[llength [info commands try]]} return

# The code below was snarfed from the Tcl core, as a forward
# compatible implementation of try/catch/finally for Tcl 8.5.

# TIP #329: [try]
# This is a *temporary* implementation, to be replaced with one in C and
# bytecode at a later date before 8.6.0
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]
			##nagelfar ignore
		    } elseif {![string is integer -strict $code]} {
			set msgPart [join [dict keys $magicCodes] {", "}]
			error "bad code '[lindex $args $i]': must be\
			    integer or \"$msgPart\""
		    }
		    ##nagelfar ignore
		    set code [format %d $code]
		    lappend handlers [lrange $args $i $i] $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