Add basic Tcl implementation of 'try ... finally'

3 files changed, 122 insertions, 15 deletions

diff --git a/doc/jim_tcl.txt b/doc/jim_tcl.txt
index 4950c6f..ece2547 100644
--- a/doc/jim_tcl.txt
+++ b/doc/jim_tcl.txt
@@ -76,6 +76,7 @@ Since v0.61:
 14. Allow 'incr' to increment an unset variable by first setting to 0
 15. Allow 'args' and optional arguments to the left or required arguments in 'proc'
 16. Add 'file copy'
+17. Add 'try ... finally' command
 
 TCL INTRODUCTION
 -----------------
@@ -3382,6 +3383,30 @@ in microseconds.
 
 Time is measured in elapsed time, not CPU time.
 
+try
+~~~
++*try* 'script' *finally* 'finalscript'+
+
+The 'try' command is provided as a convenience for exception handling.
+This interpeter evaluates *script* and then, regardless of any error
+generated, evaluates *finalscript*.
+
+The result of this command is the result of *script*, except in the
+case where *script* did not generate an error and *finalscript*
+did. In this case, the result is the result of *finalscript*.
+
+For example:
+
+	set f [open input]
+    try {
+		process $f
+	} finally {
+		$f close
+	}
+
+Will close the file even if an error occurs during 'process'. The result will
+be the result of 'process'
+
 unknown
 ~~~~~~~
 +*unknown* 'cmdName ?arg arg ...?'+
diff --git a/tclcompat.tcl b/tclcompat.tcl
index a8cbefb..c996c19 100644
--- a/tclcompat.tcl
+++ b/tclcompat.tcl
@@ -28,7 +28,7 @@ proc case {var args} {
 
 	# Check for odd number of args
 	if {[llength $args] % 2 != 0} {
-		error "extra case pattern with no body"
+		return -code error "extra case pattern with no body"
 	}
 
 	# Internal function to match a value agains a list of patterns
@@ -111,24 +111,41 @@ proc {info nameofexecutable} {} {
 
 # Implements 'file copy' - single file mode only
 proc {file copy} {{force {}} source target} {
-	if {$force ni {{} -force}} {
-		return -code error "bad option \"$force\": should be -force"
-	}
-	if {[catch {open $source} in]} {
-		return -code error $in
-	}
-	if {$force eq "" && [file exists $target]} {
-		$in close
-		return -code error "error copying \"$source\" to \"$target\": file already exists"
-	}
 	set rc [catch {
-		set out [open $target w]
-		bio copy $in $out
-		$out close
+		if {$force ni {{} -force}} {
+			error "bad option \"$force\": should be -force"
+		}
+		set in [open $source]
+
+		try {
+			if {$force eq "" && [file exists $target]} {
+				$in close
+				error "error copying \"$source\" to \"$target\": file already exists"
+			}
+			set out [open $target w]
+			bio copy $in $out
+			$out close
+		} finally {
+			catch {$in close}
+		}
 	} result]
-	$in close
 
 	return -code $rc $result
 }
 
+# Poor mans try/catch/finally
+# Note that in this version 'finally' is required
+proc try {script finally finalscript} {
+	if {$finally ne "finally"} {
+		return -code error {mis-spelt "finally" keyword}
+	}
+	set bodycode [catch [list uplevel 1 $script] bodymsg]
+	set finalcode [catch [list uplevel 1 $finalscript] finalmsg]
+	if {$bodycode || !$finalcode} {
+		return -code $bodycode $bodymsg
+	}
+	return -code $finalcode $finalmsg
+}
+
+
 set ::tcl_platform(platform) unix
diff --git a/tests/try.test b/tests/try.test
new file mode 100644
index 0000000..3cc86fb
--- /dev/null
+++ b/tests/try.test
@@ -0,0 +1,65 @@
+source testing.tcl
+
+test try-1.1 "Simple case" {
+	try {
+		set x 0
+	} finally {
+		incr x
+	}
+} 0
+
+test try-1.2 "Error in body" {
+	list [catch {
+		try {
+			set x 0
+			error message
+		} finally {
+			incr x
+		}
+	} msg] $msg $x
+} {1 message 1}
+
+test try-1.3 "Error in finally" {
+	list [catch {
+		try {
+			set x 0
+		} finally {
+			incr x
+			error finally
+		}
+	} msg] $msg $x
+} {1 finally 1}
+
+test try-1.4 "Error in both" {
+	list [catch {
+		try {
+			set x 0
+			error message
+		} finally {
+			incr x
+			error finally
+		}
+	} msg] $msg $x
+} {1 message 1}
+
+test try-1.5 "break in body" {
+	list [catch {
+		try {
+			set x 0
+			break
+		} finally {
+			incr x
+		}
+	} msg] $msg $x
+} {3 {} 1}
+
+test try-1.6 "break in finally" {
+	list [catch {
+		try {
+			set x 0
+		} finally {
+			incr x
+			break
+		}
+	} msg] $msg $x
+} {3 {} 1}