From eb1918117c0ae5f2b67d441f2ed459718e79cad4 Mon Sep 17 00:00:00 2001 From: Steve Bennett Date: Mon, 28 Aug 2017 10:03:21 +1000 Subject: [PATCH] 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 --- TODO | 10 +-- jim.c | 54 ++++++++++++- jim_tcl.txt | 25 ++++++ stdlib.tcl | 7 ++ tests/defer.test | 237 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 325 insertions(+), 8 deletions(-) create mode 100644 tests/defer.test 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 -- 2.11.4.GIT