tcllib 1.17-dfsg-1 / usr / share / tcltk / tcllib1.17 / try / try.tcl

# # ## ### ##### ######## ############# ####################
## -*- 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