Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

6 files changed, 419 insertions, 0 deletions

diff --git a/tcllib/modules/try/ChangeLog b/tcllib/modules/try/ChangeLog
new file mode 100644
index 0000000..bb5767b
--- /dev/null
+++ b/tcllib/modules/try/ChangeLog
@@ -0,0 +1,22 @@
+2013-02-01  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.15 ========================
+	* 
+
+2012-06-25  Andreas Kupries  <andreask@activestate.com>
+
+	* try.man: Renamed to tcllib_try.man to prevent clash with Tcl
+	  core manpage. Effectively removed.
+	* tcllib_try.man: Effectively added, new name of try.man.
+
+2011-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.14 ========================
+	* 
+
+2011-05-31  Andreas Kupries  <andreask@activestate.com>
+
+	* New module and package: try. Tcl 8.5+ forward compatibility
+	  implementation of try/catch/finally (TIP 329).
diff --git a/tcllib/modules/try/pkgIndex.tcl b/tcllib/modules/try/pkgIndex.tcl
new file mode 100644
index 0000000..5e7f896
--- /dev/null
+++ b/tcllib/modules/try/pkgIndex.tcl
@@ -0,0 +1,13 @@
+#checker -scope global exclude warnUndefinedVar
+# var in question is 'dir'.
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+    # PRAGMA: returnok
+    return
+}
+# The package below is a backward compatible implementation of
+# try/catch/finally, for use by Tcl 8.5 only. On 8.6 it does nothing.
+package ifneeded try   1 [list source [file join $dir try.tcl]]
+
+# The package below is a backward compatible implementation of
+# "throw", for use by Tcl 8.5 only. On 8.6 it does nothing.
+package ifneeded throw 1 [list source [file join $dir throw.tcl]]
diff --git a/tcllib/modules/try/tcllib_throw.man b/tcllib/modules/try/tcllib_throw.man
new file mode 100644
index 0000000..c598cfe
--- /dev/null
+++ b/tcllib/modules/try/tcllib_throw.man
@@ -0,0 +1,39 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin try n 1]
+[see_also error(n)]
+[keywords error]
+[keywords throw]
+[keywords return]
+
+[copyright {2015 Miguel Martínez López, BSD licensed}]
+[moddesc {Forward compatibility implementation of [throw]}]
+[titledesc {throw - Throw an error exception with a message}]
+[category  Utility]
+[require Tcl 8.5]
+[require throw [opt 1]]
+[description]
+[para]
+
+This package provides a forward-compatibility implementation of Tcl
+8.6's throw command (TIP 329), for Tcl 8.5. The code was
+directly pulled from Tcl 8.6 revision ?, when try/finally was
+implemented as Tcl procedure instead of in C.
+
+[list_begin definitions]
+[comment {- - -- --- ----- -------- ------------- ---------------------}]
+[call [cmd ::throw] [arg error_code] [arg error_message]]
+
+throw is merely a reordering of the arguments of the error command. It throws an error with the indicated 
+error code and error message.
+
+[list_end]
+
+[section EXAMPLES]
+
+[para][example_begin]
+[cmd throw] {MYERROR CODE} "My error message"
+[example_end]
+
+[vset CATEGORY try]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/try/tcllib_try.man b/tcllib/modules/try/tcllib_try.man
new file mode 100644
index 0000000..434b5a0
--- /dev/null
+++ b/tcllib/modules/try/tcllib_try.man
@@ -0,0 +1,122 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin try n 1]
+[see_also catch(n)]
+[see_also error(n)]
+[see_also return(n)]
+[see_also throw(n)]
+[keywords cleanup]
+[keywords error]
+[keywords exception]
+[keywords final]
+[keywords {resource management}]
+[copyright {2008 Donal K. Fellows, BSD licensed}]
+[moddesc {Forward compatibility implementation of [try]}]
+[titledesc {try - Trap and process errors and exceptions}]
+[category  Utility]
+[require Tcl 8.5]
+[require try [opt 1]]
+[description]
+[para]
+
+This package provides a forward-compatibility implementation of Tcl
+8.6's try/finally command (TIP 329), for Tcl 8.5. The code was
+directly pulled from Tcl 8.6 revision ?, when try/finally was
+implemented as Tcl procedure instead of in C.
+
+[list_begin definitions]
+[comment {- - -- --- ----- -------- ------------- ---------------------}]
+[call [cmd ::try] [arg body] [opt [arg handler...]] [opt "[method finally] [arg script]"]]
+
+This command executes the script [arg body] and, depending on what the
+outcome of that script is (normal exit, error, or some other
+exceptional result), runs a handler script to deal with the case. Once
+that has all happened, if the [method finally] clause is present, the
+[arg script] it includes will be run and the result of the handler (or
+the [arg body] if no handler matched) is allowed to continue to
+propagate. Note that the [method finally] clause is processed even if
+an error occurs and irrespective of which, if any, [arg handler] is
+used.
+
+[para] The [arg handler] clauses are each expressed as several words,
+and must have one of the following forms:
+
+[list_begin definitions]
+[def "[method on] [arg {code variableList script}]"]
+
+This clause matches if the evaluation of [arg body] completed with the
+exception code [arg code]. The [arg code] may be expressed as an
+integer or one of the following literal words:
+
+[const ok], [const error], [const return], [const break], or
+[const continue]. Those literals correspond to the integers 0 through
+4 respectively.
+
+[def "[method trap] [arg {pattern variableList script}]"]
+
+This clause matches if the evaluation of [arg body] resulted in an
+error and the prefix of the [option -errorcode] from the interpreter's
+status dictionary is equal to the [arg pattern]. The number of prefix
+words taken from the [option -errorcode] is equal to the list-length
+of [arg pattern], and inter-word spaces are normalized in both the
+[option -errorcode] and [arg pattern] before comparison.
+
+[para] The [arg variableList] word in each [arg handler] is always
+interpreted as a list of variable names. If the first word of the list
+is present and non-empty, it names a variable into which the result of
+the evaluation of [arg body] (from the main [cmd try]) will be placed;
+this will contain the human-readable form of any errors. If the second
+word of the list is present and non-empty, it names a variable into
+which the options dictionary of the interpreter at the moment of
+completion of execution of [arg body] will be placed.
+
+[para] The [arg script] word of each [arg handler] is also always
+interpreted the same: as a Tcl script to evaluate if the clause is
+matched. If [arg script] is a literal [const -] and the [arg handler]
+is not the last one, the [arg script] of the following [arg handler]
+is invoked instead (just like with the [cmd switch] command).
+
+[para] Note that [arg handler] clauses are matched against in order,
+and that the first matching one is always selected.
+
+At most one [arg handler] clause will selected.
+
+As a consequence, an [method {on error}] will mask any subsequent
+[method trap] in the [cmd try]. Also note that [method {on error}] is
+equivalent to [method {trap {}}].
+
+[para] If an exception (i.e. any non-[const ok] result) occurs during
+the evaluation of either the [arg handler] or the [method finally]
+clause, the original exception's status dictionary will be added to
+the new exception's status dictionary under the [option -during] key.
+
+[list_end]
+[list_end]
+
+[section EXAMPLES]
+
+Ensure that a file is closed no matter what:
+
+[para][example_begin]
+set f [lb]open /some/file/name a[rb]
+[cmd try] {
+    puts \$f "some message"
+    # ...
+} [cmd finally] {
+    close \$f
+}
+[example_end]
+
+[para] Handle different reasons for a file to not be openable for reading:
+[para][example_begin]
+[cmd try] {
+    set f [lb]open /some/file/name[rb]
+} [method trap] {POSIX EISDIR} {} {
+    puts "failed to open /some/file/name: it's a directory"
+} [method trap] {POSIX ENOENT} {} {
+    puts "failed to open /some/file/name: it doesn't exist"
+}
+[example_end]
+
+[vset CATEGORY try]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/try/throw.tcl b/tcllib/modules/try/throw.tcl
new file mode 100644
index 0000000..132ab3d
--- /dev/null
+++ b/tcllib/modules/try/throw.tcl
@@ -0,0 +1,18 @@
+# # ## ### ##### ######## ############# ####################
+## -*- tcl -*-
+## (C) 2015 Miguel Martínez López, BSD licensed.
+
+# The code here is a forward-compatibility implementation of Tcl 8.6's
+# throw command (TIP 329), for Tcl 8.5.
+
+# # ## ### ##### ######## ############# ####################
+
+package provide throw 1
+package require Tcl 8.5
+
+# Do nothing if the "throw" command exists already (8.6 and higher).
+if {[llength [info commands throw]]} return
+
+proc throw {code msg} {
+    return -code error -errorcode $code $msg
+}
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