Implement defer, $jim::defer

Allows commands to run when a proc or interpreter exits.

If the $jim::defer variables exists at proc or interp exit,
it is treated as a list of scripts to evaluate (in reverse order).

The [defer] command is a helper to add scripts to $jim::defer

See tests/defer.test

Signed-off-by: Steve Bennett <steveb@workware.net.au>

5 files changed, 325 insertions, 8 deletions

diff --git a/TODO b/TODO
index fc62aef..68e74fe 100644
--- a/TODO
+++ b/TODO
@@ -1,13 +1,10 @@
 CORE LANGUAGE FEATURES
 
-CORE COMMANDS
+- none
 
-- [onleave] command, executing something as soon as the current procedure
-  returns. With no arguments it returns the script set, with one appends
-  the onleave script. There should be a way to reset.
+CORE COMMANDS
 
-  Currently we have [local] which can be used to delete procs on proc exit.
-  Also try/on/finally. Is [onleave] really needed?
+- none
 
 OTHER COMMANDS NOT IN TCL BUT THAT SHOULD BE IN JIM
 
@@ -17,7 +14,6 @@ EXTENSIONS
 
 - Cryptography: hash functions, block ciphers, strim ciphers, PRNGs.
 - Tuplespace extension (http://wiki.tcl.tk/3947) (using sqlite as backend)
-- Zlib
 - Gdlib
 - CGI (interface compatible with ncgi, but possibly written in C for speed)
 
diff --git a/jim.c b/jim.c
index 83a42a2..131924c 100644
--- a/jim.c
+++ b/jim.c
@@ -5025,6 +5025,55 @@ static int JimDeleteLocalProcs(Jim_Interp *interp, Jim_Stack *localCommands)
     return JIM_OK;
 }
 
+/**
+ * Run any $jim::defer scripts for the current call frame.
+ *
+ * retcode is the return code from the current proc.
+ *
+ * Returns the new return code.
+ */
+static int JimInvokeDefer(Jim_Interp *interp, int retcode)
+{
+    Jim_Obj *objPtr = Jim_GetVariableStr(interp, "jim::defer", JIM_NONE);
+    int ret = JIM_OK;
+
+    if (objPtr) {
+        int i;
+        int listLen = Jim_ListLength(interp, objPtr);
+        Jim_Obj *resultObjPtr;
+
+        Jim_IncrRefCount(objPtr);
+
+        /* Need to save away the current interp result and
+         * restore it if appropriate
+         */
+        resultObjPtr = Jim_GetResult(interp);
+        Jim_IncrRefCount(resultObjPtr);
+        Jim_SetEmptyResult(interp);
+
+        /* Invoke in reverse order */
+        for (i = listLen; i > 0; i--) {
+            /* If a defer script returns an error, don't evaluate remaining scripts */
+            Jim_Obj *scriptObjPtr = Jim_ListGetIndex(interp, objPtr, i - 1);
+            ret = Jim_EvalObj(interp, scriptObjPtr);
+            if (ret != JIM_OK) {
+                break;
+            }
+        }
+
+        if (ret == JIM_OK || retcode == JIM_ERR) {
+            /* defer script had no error, or proc had an error so restore proc result */
+            Jim_SetResult(interp, resultObjPtr);
+        }
+        else {
+            retcode = ret;
+        }
+
+        Jim_DecrRefCount(interp, resultObjPtr);
+        Jim_DecrRefCount(interp, objPtr);
+    }
+    return retcode;
+}
 
 #define JIM_FCF_FULL 0          /* Always free the vars hash table */
 #define JIM_FCF_REUSE 1         /* Reuse the vars hash table if possible */
@@ -5545,6 +5594,8 @@ void Jim_FreeInterp(Jim_Interp *i)
 
     /* Free the active call frames list - must be done before i->commands is destroyed */
     for (cf = i->framePtr; cf; cf = cfx) {
+        /* Note that we ignore any errors */
+        JimInvokeDefer(i, JIM_OK);
         cfx = cf->parent;
         JimFreeCallFrame(i, cf, JIM_FCF_FULL);
     }
@@ -10810,7 +10861,8 @@ static int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, Jim_Obj
 
 badargset:
 
-    /* Free the callframe */
+    /* Invoke $jim::defer then destroy the callframe */
+    retcode = JimInvokeDefer(interp, retcode);
     interp->framePtr = interp->framePtr->parent;
     JimFreeCallFrame(interp, callFramePtr, JIM_FCF_REUSE);
 
diff --git a/jim_tcl.txt b/jim_tcl.txt
index 7a736c1..6027873 100644
--- a/jim_tcl.txt
+++ b/jim_tcl.txt
@@ -60,6 +60,8 @@ Changes between 0.77 and 0.78
 4. Add scriptable autocompletion support in interactive mode with `tcl::autocomplete`
 5. Add `aio sockopt`
 6. Add scriptable autocompletion support with `history completion`
+7. Add support for `tree delete`
+8. Add support for `defer` and '$jim::defer'
 
 Changes between 0.76 and 0.77
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3243,6 +3245,21 @@ If +-index 'listindex'+ is specified, each element of the list is treated as a l
 the given index is extracted from the list for comparison. The list index may
 be any valid list index, such as +1+, +end+ or +end-2+.
 
+defer
+~~~~~
++*defer* 'script'+
+
+This command is a simple helper command to add a script to the '+$jim::defer+' variable
+that will run when the current proc or interpreter exits. For example:
+
+    jim> proc a {} { defer {puts "Leaving a"}; puts "Exit" }
+    jim> a
+    Exit
+    Leaving a
+
+If the '+$jim::defer+' variable exists, it is treated as a list of scripts to run
+when the proc or interpreter exits.
+
 open
 ~~~~
 +*open* 'fileName ?access?'+
@@ -5164,6 +5181,14 @@ The following global variables are set by jimsh.
 +*jim::argv0*+::
     The value of argv[0] when jimsh was invoked.
 
+The following variables have special meaning to Jim Tcl:
+
++*jim::defer*+::
+    If this variable is set, it is considered to be a list of scripts to evaluate
+	when the current proc exits (local variables), or the interpreter exits (global variable).
+	See `defer`.
+
+
 CHANGES IN PREVIOUS RELEASES
 ----------------------------
 
diff --git a/stdlib.tcl b/stdlib.tcl
index 7fd1313..37a8007 100644
--- a/stdlib.tcl
+++ b/stdlib.tcl
@@ -66,6 +66,13 @@ proc stackdump {stacktrace} {
 	join $lines \n
 }
 
+# Add the given script to $jim::defer, to be evaluated when the current
+# procedure exits
+proc defer {script} {
+	upvar jim::defer v
+	lappend v $script
+}
+
 # Sort of replacement for $::errorInfo
 # Usage: errorInfo error ?stacktrace?
 proc errorInfo {msg {stacktrace ""}} {
diff --git a/tests/defer.test b/tests/defer.test
new file mode 100644
index 0000000..c714656
--- /dev/null
+++ b/tests/defer.test
@@ -0,0 +1,237 @@
+# vim:se syntax=tcl:
+
+source [file dirname [info script]]/testing.tcl
+
+needs cmd defer
+needs cmd interp
+
+test defer-1.1 {defer in proc} {
+	set x -
+	proc a {} {
+		set x +
+		# This does nothing since it increments a local variable
+		defer {append x L}
+		# This increments the global variable
+		defer {append ::x G}
+		# Will return "-", not "-L" since return happens before defer triggers
+		return $x
+	}
+	list [a] $x
+} {+ -G}
+
+test defer-1.2 {set $defer directly} {
+	set x -
+	proc a {} {
+		lappend jim::defer {append ::x a}
+		lappend jim::defer {append ::x b}
+		return $jim::defer
+	}
+	list [a] $x
+} {{{append ::x a} {append ::x b}} -ba}
+
+
+test defer-1.3 {unset $defer} {
+	set x -
+	proc a {} {
+		defer {append ::x a}
+		# unset, to remove all defer actions
+		unset jim::defer
+	}
+	a
+	set x
+} {-}
+
+test defer-1.4 {error in defer - error} {
+	set x -
+	proc a {} {
+		# First defer script will not happen because of error in next defer script
+		defer {append ::x a}
+		# Error ignored because of error from proc
+		defer {blah}
+		# Last defer script will happen
+		defer {append ::x b}
+		# This error will take precedence over the error from defer
+		error "from a"
+	}
+	set rc [catch {a} msg]
+	list [info ret $rc] $msg $x
+} {error {from a} -b}
+
+test defer-1.5 {error in defer - return} {
+	set x -
+	proc a {} {
+		# First defer script will not happen
+		defer {append ::x a}
+		defer {blah}
+		# Last defer script will happen
+		defer {append ::x b}
+		return 3
+	}
+	set rc [catch {a} msg]
+	list [info ret $rc] $msg $x
+} {error {invalid command name "blah"} -b}
+
+test defer-1.6 {error in defer - ok} {
+	set x -
+	proc a {} {
+		# First defer script will not happen
+		defer {append ::x a}
+		# Error ignored because of error from proc
+		defer {blah}
+		# Last defer script will happen
+		defer {append ::x b}
+	}
+	set rc [catch {a} msg]
+	list [info ret $rc] $msg $x
+} {error {invalid command name "blah"} -b}
+
+test defer-1.7 {error in defer - break} {
+	set x -
+	proc a {} {
+		# First defer script will not happen
+		defer {append ::x a}
+		# This non-zero return code will take precedence over the proc return
+		defer {return -code 30 ret30}
+		# Last defer script will happen
+		defer {append ::x b}
+
+		return -code 20 ret20
+	}
+	set rc [catch {a} msg]
+	list [info ret $rc] $msg $x
+} {30 ret30 -b}
+
+test defer-1.8 {error in defer - tailcall} {
+	set x -
+	proc a {} {
+		# This will prevent tailcall from happening
+		defer {blah}
+
+		# Tailcall will not happen because of error in defer
+		tailcall append ::x a
+	}
+	set rc [catch {a} msg]
+	list [info ret $rc] $msg $x
+} {error {invalid command name "blah"} -}
+
+test defer-1.9 {Add to defer in defer body} {
+	set x -
+	proc a {} {
+		defer {
+			# Add to defer in defer
+			defer {
+				# This will do nothing
+				error here
+			}
+		}
+		defer {append ::x a}
+	}
+	a
+	set x
+} {-a}
+
+test defer-1.10 {Unset defer in defer body} {
+	set x -
+	proc a {} {
+		defer {
+			# This will do nothing
+			unset -nocomplain jim::defer
+		}
+		defer {append ::x a}
+	}
+	a
+	set x
+} {-a}
+
+test defer-1.11 {defer through tailcall} {
+	set x {}
+	proc a {} {
+		defer {append ::x a}
+		b
+	}
+	proc b {} {
+		defer {append ::x b}
+		# c will be invoked as through called from a but this
+		# won't make any difference for defer
+		tailcall c
+	}
+	proc c {} {
+		defer {append ::x c}
+	}
+	a
+	set x
+} {bca}
+
+test defer-1.12 {defer in recursive call} {
+	set x {}
+	proc a {n} {
+		# defer happens just before the return, so after the recursive call to a
+		defer {lappend ::x $n}
+		if {$n > 0} {
+			a $($n - 1)
+		}
+	}
+	a 3
+	set x
+} {0 1 2 3}
+
+test defer-1.13 {defer in recursive tailcall} {
+	set x {}
+	proc a {n} {
+		# defer happens just before the return, so before the tailcall to a
+		defer {lappend ::x $n}
+		if {$n > 0} {
+			tailcall a $($n - 1)
+		}
+	}
+	a 3
+	set x
+} {3 2 1 0}
+
+test defer-1.14 {defer capture variables} {
+	set x {}
+	proc a {} {
+		set y 1
+		# A normal defer will evaluate at the end of the proc, so $y may change
+		defer {lappend ::x $y}
+		incr y
+
+		# What if we want to capture the value of y here? list will work
+		defer [list lappend ::x $y]
+		incr y
+
+		# But with multiple statements, list doesn't work, so use a lambda 
+		# to capture the value instead
+		defer [lambda {} {y} {
+			# multi-line script
+			lappend ::x $y
+		}]
+		incr y
+
+		return $y
+	}
+	list [a] $x
+} {4 {3 2 4}}
+
+test defer-2.1 {defer from interp} -body {
+	set i [interp]
+	# defer needs to have some effect to detect on exit,
+	# so write to a file
+	file delete defer.tmp
+	$i eval {
+		defer {
+			[open defer.tmp w] puts "leaving child"
+		}
+	}
+	set a [file exists defer.tmp]
+	$i delete
+	# Now the file should exist
+	set f [open defer.tmp]
+	$f gets b
+	$f close
+	list $a $b
+} -result {0 {leaving child}} -cleanup {
+	file delete defer.tmp
+}
+
+testreport