Skip to content

Commit eb19181

Browse files
mstevebmsteveb
committed
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>
1 parent a5877cb commit eb19181

File tree

5 files changed

+325
-8
lines changed

5 files changed

+325
-8
lines changed

‎TODO

+3-7
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,10 @@
11
CORE LANGUAGE FEATURES
22

3-
CORE COMMANDS
3+
- none
44

5-
- [onleave] command, executing something as soon as the current procedure
6-
returns. With no arguments it returns the script set, with one appends
7-
the onleave script. There should be a way to reset.
5+
CORE COMMANDS
86

9-
Currently we have [local] which can be used to delete procs on proc exit.
10-
Also try/on/finally. Is [onleave] really needed?
7+
- none
118

129
OTHER COMMANDS NOT IN TCL BUT THAT SHOULD BE IN JIM
1310

@@ -17,7 +14,6 @@ EXTENSIONS
1714

1815
- Cryptography: hash functions, block ciphers, strim ciphers, PRNGs.
1916
- Tuplespace extension (http://wiki.tcl.tk/3947) (using sqlite as backend)
20-
- Zlib
2117
- Gdlib
2218
- CGI (interface compatible with ncgi, but possibly written in C for speed)
2319

‎jim.c

+53-1
Original file line numberDiff line numberDiff line change
@@ -5025,6 +5025,55 @@ static int JimDeleteLocalProcs(Jim_Interp *interp, Jim_Stack *localCommands)
50255025
return JIM_OK;
50265026
}
50275027

5028+
/**
5029+
* Run any $jim::defer scripts for the current call frame.
5030+
*
5031+
* retcode is the return code from the current proc.
5032+
*
5033+
* Returns the new return code.
5034+
*/
5035+
static int JimInvokeDefer(Jim_Interp *interp, int retcode)
5036+
{
5037+
Jim_Obj *objPtr = Jim_GetVariableStr(interp, "jim::defer", JIM_NONE);
5038+
int ret = JIM_OK;
5039+
5040+
if (objPtr) {
5041+
int i;
5042+
int listLen = Jim_ListLength(interp, objPtr);
5043+
Jim_Obj *resultObjPtr;
5044+
5045+
Jim_IncrRefCount(objPtr);
5046+
5047+
/* Need to save away the current interp result and
5048+
* restore it if appropriate
5049+
*/
5050+
resultObjPtr = Jim_GetResult(interp);
5051+
Jim_IncrRefCount(resultObjPtr);
5052+
Jim_SetEmptyResult(interp);
5053+
5054+
/* Invoke in reverse order */
5055+
for (i = listLen; i > 0; i--) {
5056+
/* If a defer script returns an error, don't evaluate remaining scripts */
5057+
Jim_Obj *scriptObjPtr = Jim_ListGetIndex(interp, objPtr, i - 1);
5058+
ret = Jim_EvalObj(interp, scriptObjPtr);
5059+
if (ret != JIM_OK) {
5060+
break;
5061+
}
5062+
}
5063+
5064+
if (ret == JIM_OK || retcode == JIM_ERR) {
5065+
/* defer script had no error, or proc had an error so restore proc result */
5066+
Jim_SetResult(interp, resultObjPtr);
5067+
}
5068+
else {
5069+
retcode = ret;
5070+
}
5071+
5072+
Jim_DecrRefCount(interp, resultObjPtr);
5073+
Jim_DecrRefCount(interp, objPtr);
5074+
}
5075+
return retcode;
5076+
}
50285077

50295078
#define JIM_FCF_FULL 0 /* Always free the vars hash table */
50305079
#define JIM_FCF_REUSE 1 /* Reuse the vars hash table if possible */
@@ -5545,6 +5594,8 @@ void Jim_FreeInterp(Jim_Interp *i)
55455594

55465595
/* Free the active call frames list - must be done before i->commands is destroyed */
55475596
for (cf = i->framePtr; cf; cf = cfx) {
5597+
/* Note that we ignore any errors */
5598+
JimInvokeDefer(i, JIM_OK);
55485599
cfx = cf->parent;
55495600
JimFreeCallFrame(i, cf, JIM_FCF_FULL);
55505601
}
@@ -10810,7 +10861,8 @@ static int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, Jim_Obj
1081010861

1081110862
badargset:
1081210863

10813-
/* Free the callframe */
10864+
/* Invoke $jim::defer then destroy the callframe */
10865+
retcode = JimInvokeDefer(interp, retcode);
1081410866
interp->framePtr = interp->framePtr->parent;
1081510867
JimFreeCallFrame(interp, callFramePtr, JIM_FCF_REUSE);
1081610868

‎jim_tcl.txt

+25
Original file line numberDiff line numberDiff line change
@@ -60,6 +60,8 @@ Changes between 0.77 and 0.78
6060
4. Add scriptable autocompletion support in interactive mode with `tcl::autocomplete`
6161
5. Add `aio sockopt`
6262
6. Add scriptable autocompletion support with `history completion`
63+
7. Add support for `tree delete`
64+
8. Add support for `defer` and '$jim::defer'
6365

6466
Changes between 0.76 and 0.77
6567
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3243,6 +3245,21 @@ If +-index 'listindex'+ is specified, each element of the list is treated as a l
32433245
the given index is extracted from the list for comparison. The list index may
32443246
be any valid list index, such as +1+, +end+ or +end-2+.
32453247

3248+
defer
3249+
~~~~~
3250+
+*defer* 'script'+
3251+
3252+
This command is a simple helper command to add a script to the '+$jim::defer+' variable
3253+
that will run when the current proc or interpreter exits. For example:
3254+
3255+
jim> proc a {} { defer {puts "Leaving a"}; puts "Exit" }
3256+
jim> a
3257+
Exit
3258+
Leaving a
3259+
3260+
If the '+$jim::defer+' variable exists, it is treated as a list of scripts to run
3261+
when the proc or interpreter exits.
3262+
32463263
open
32473264
~~~~
32483265
+*open* 'fileName ?access?'+
@@ -5164,6 +5181,14 @@ The following global variables are set by jimsh.
51645181
+*jim::argv0*+::
51655182
The value of argv[0] when jimsh was invoked.
51665183

5184+
The following variables have special meaning to Jim Tcl:
5185+
5186+
+*jim::defer*+::
5187+
If this variable is set, it is considered to be a list of scripts to evaluate
5188+
when the current proc exits (local variables), or the interpreter exits (global variable).
5189+
See `defer`.
5190+
5191+
51675192
CHANGES IN PREVIOUS RELEASES
51685193
----------------------------
51695194

‎stdlib.tcl

+7
Original file line numberDiff line numberDiff line change
@@ -66,6 +66,13 @@ proc stackdump {stacktrace} {
6666
join $lines \n
6767
}
6868

69+
# Add the given script to $jim::defer, to be evaluated when the current
70+
# procedure exits
71+
proc defer {script} {
72+
upvar jim::defer v
73+
lappend v $script
74+
}
75+
6976
# Sort of replacement for $::errorInfo
7077
# Usage: errorInfo error ?stacktrace?
7178
proc errorInfo {msg {stacktrace ""}} {

‎tests/defer.test

+237
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,237 @@
1+
# vim:se syntax=tcl:
2+
3+
source [file dirname [info script]]/testing.tcl
4+
5+
needs cmd defer
6+
needs cmd interp
7+
8+
test defer-1.1 {defer in proc} {
9+
set x -
10+
proc a {} {
11+
set x +
12+
# This does nothing since it increments a local variable
13+
defer {append x L}
14+
# This increments the global variable
15+
defer {append ::x G}
16+
# Will return "-", not "-L" since return happens before defer triggers
17+
return $x
18+
}
19+
list [a] $x
20+
} {+ -G}
21+
22+
test defer-1.2 {set $defer directly} {
23+
set x -
24+
proc a {} {
25+
lappend jim::defer {append ::x a}
26+
lappend jim::defer {append ::x b}
27+
return $jim::defer
28+
}
29+
list [a] $x
30+
} {{{append ::x a} {append ::x b}} -ba}
31+
32+
33+
test defer-1.3 {unset $defer} {
34+
set x -
35+
proc a {} {
36+
defer {append ::x a}
37+
# unset, to remove all defer actions
38+
unset jim::defer
39+
}
40+
a
41+
set x
42+
} {-}
43+
44+
test defer-1.4 {error in defer - error} {
45+
set x -
46+
proc a {} {
47+
# First defer script will not happen because of error in next defer script
48+
defer {append ::x a}
49+
# Error ignored because of error from proc
50+
defer {blah}
51+
# Last defer script will happen
52+
defer {append ::x b}
53+
# This error will take precedence over the error from defer
54+
error "from a"
55+
}
56+
set rc [catch {a} msg]
57+
list [info ret $rc] $msg $x
58+
} {error {from a} -b}
59+
60+
test defer-1.5 {error in defer - return} {
61+
set x -
62+
proc a {} {
63+
# First defer script will not happen
64+
defer {append ::x a}
65+
defer {blah}
66+
# Last defer script will happen
67+
defer {append ::x b}
68+
return 3
69+
}
70+
set rc [catch {a} msg]
71+
list [info ret $rc] $msg $x
72+
} {error {invalid command name "blah"} -b}
73+
74+
test defer-1.6 {error in defer - ok} {
75+
set x -
76+
proc a {} {
77+
# First defer script will not happen
78+
defer {append ::x a}
79+
# Error ignored because of error from proc
80+
defer {blah}
81+
# Last defer script will happen
82+
defer {append ::x b}
83+
}
84+
set rc [catch {a} msg]
85+
list [info ret $rc] $msg $x
86+
} {error {invalid command name "blah"} -b}
87+
88+
test defer-1.7 {error in defer - break} {
89+
set x -
90+
proc a {} {
91+
# First defer script will not happen
92+
defer {append ::x a}
93+
# This non-zero return code will take precedence over the proc return
94+
defer {return -code 30 ret30}
95+
# Last defer script will happen
96+
defer {append ::x b}
97+
98+
return -code 20 ret20
99+
}
100+
set rc [catch {a} msg]
101+
list [info ret $rc] $msg $x
102+
} {30 ret30 -b}
103+
104+
test defer-1.8 {error in defer - tailcall} {
105+
set x -
106+
proc a {} {
107+
# This will prevent tailcall from happening
108+
defer {blah}
109+
110+
# Tailcall will not happen because of error in defer
111+
tailcall append ::x a
112+
}
113+
set rc [catch {a} msg]
114+
list [info ret $rc] $msg $x
115+
} {error {invalid command name "blah"} -}
116+
117+
test defer-1.9 {Add to defer in defer body} {
118+
set x -
119+
proc a {} {
120+
defer {
121+
# Add to defer in defer
122+
defer {
123+
# This will do nothing
124+
error here
125+
}
126+
}
127+
defer {append ::x a}
128+
}
129+
a
130+
set x
131+
} {-a}
132+
133+
test defer-1.10 {Unset defer in defer body} {
134+
set x -
135+
proc a {} {
136+
defer {
137+
# This will do nothing
138+
unset -nocomplain jim::defer
139+
}
140+
defer {append ::x a}
141+
}
142+
a
143+
set x
144+
} {-a}
145+
146+
test defer-1.11 {defer through tailcall} {
147+
set x {}
148+
proc a {} {
149+
defer {append ::x a}
150+
b
151+
}
152+
proc b {} {
153+
defer {append ::x b}
154+
# c will be invoked as through called from a but this
155+
# won't make any difference for defer
156+
tailcall c
157+
}
158+
proc c {} {
159+
defer {append ::x c}
160+
}
161+
a
162+
set x
163+
} {bca}
164+
165+
test defer-1.12 {defer in recursive call} {
166+
set x {}
167+
proc a {n} {
168+
# defer happens just before the return, so after the recursive call to a
169+
defer {lappend ::x $n}
170+
if {$n > 0} {
171+
a $($n - 1)
172+
}
173+
}
174+
a 3
175+
set x
176+
} {0 1 2 3}
177+
178+
test defer-1.13 {defer in recursive tailcall} {
179+
set x {}
180+
proc a {n} {
181+
# defer happens just before the return, so before the tailcall to a
182+
defer {lappend ::x $n}
183+
if {$n > 0} {
184+
tailcall a $($n - 1)
185+
}
186+
}
187+
a 3
188+
set x
189+
} {3 2 1 0}
190+
191+
test defer-1.14 {defer capture variables} {
192+
set x {}
193+
proc a {} {
194+
set y 1
195+
# A normal defer will evaluate at the end of the proc, so $y may change
196+
defer {lappend ::x $y}
197+
incr y
198+
199+
# What if we want to capture the value of y here? list will work
200+
defer [list lappend ::x $y]
201+
incr y
202+
203+
# But with multiple statements, list doesn't work, so use a lambda
204+
# to capture the value instead
205+
defer [lambda {} {y} {
206+
# multi-line script
207+
lappend ::x $y
208+
}]
209+
incr y
210+
211+
return $y
212+
}
213+
list [a] $x
214+
} {4 {3 2 4}}
215+
216+
test defer-2.1 {defer from interp} -body {
217+
set i [interp]
218+
# defer needs to have some effect to detect on exit,
219+
# so write to a file
220+
file delete defer.tmp
221+
$i eval {
222+
defer {
223+
[open defer.tmp w] puts "leaving child"
224+
}
225+
}
226+
set a [file exists defer.tmp]
227+
$i delete
228+
# Now the file should exist
229+
set f [open defer.tmp]
230+
$f gets b
231+
$f close
232+
list $a $b
233+
} -result {0 {leaving child}} -cleanup {
234+
file delete defer.tmp
235+
}
236+
237+
testreport

0 commit comments

Comments
 (0)