Fossil SCM

Use macros to tidy up TH1 to Tcl argument marshalling. Use the Tcl interp result when Tcl_ExprObj does not return ok. Check for Tcl interp deletion. The TH1 'puts' command should flush when writing to stdout. Add 'repository' TH1 command. Use obj API to get Tcl cmdInfo. Add tests for Tcl integration.

mistachkin 2011-08-28 23:45 tcl-integration
Commit 53b9445b2c048214c6e649284aa4bfd02bd4a8b6
Parent 5cc15d08900cd34…
10 files changed +31 +79 -49 +47 +22 +6 +9 +9 +5 +9 +18
~ src/th_main.c ~ src/th_tcl.c + test/th1-tcl.test + test/th1-tcl1.txt + test/th1-tcl2.txt + test/th1-tcl3.txt + test/th1-tcl4.txt + test/th1-tcl5.txt + test/th1-tcl6.txt + test/th1-tcl7.txt
M src/th_main.c
+31
--- src/th_main.c
+++ src/th_main.c
@@ -93,10 +93,11 @@
9393
 }
9494
 if( g.cgiOutput ){
9595
 cgi_append_content(z, n);
9696
 }else{
9797
 fwrite(z, 1, n, stdout);
98
+ fflush(stdout);
9899
 }
99100
 if( encode ) free((char*)z);
100101
 }
101102
 }
102103
@@ -334,10 +335,39 @@
334335
 if( n<iMin ) n = iMin;
335336
 if( n>iMax ) n = iMax;
336337
 Th_SetResultInt(interp, n);
337338
 return TH_OK;
338339
 }
340
+
341
+/*
342
+** TH1 command: repository ?BOOLEAN?
343
+**
344
+** Return the fully qualified file name of the open repository or an empty
345
+** string if one is not currently open. Optionally, it will attempt to open
346
+** the repository if the boolean argument is non-zero.
347
+*/
348
+static int repositoryCmd(
349
+ Th_Interp *interp,
350
+ void *p,
351
+ int argc,
352
+ const char **argv,
353
+ int *argl
354
+){
355
+ int openRepository;
356
+
357
+ if( argc!=1 && argc!=2 ){
358
+ return Th_WrongNumArgs(interp, "repository ?BOOLEAN?");
359
+ }
360
+ if( argc==2 ){
361
+ if( Th_ToInt(interp, argv[1], argl[1], &openRepository) ){
362
+ return TH_ERROR;
363
+ }
364
+ if( openRepository ) db_find_and_open_repository(OPEN_OK_NOT_FOUND, 0);
365
+ }
366
+ Th_SetResult(interp, g.zRepositoryName, -1);
367
+ return TH_OK;
368
+}
339369
340370
 /*
341371
 ** Make sure the interpreter has been initialized. Initialize it if
342372
 ** it has not been already.
343373
 **
@@ -357,10 +387,11 @@
357387
 {"htmlize", htmlizeCmd, 0},
358388
 {"date", dateCmd, 0},
359389
 {"html", putsCmd, 0},
360390
 {"puts", putsCmd, (void*)1},
361391
 {"wiki", wikiCmd, 0},
392
+ {"repository", repositoryCmd, 0},
362393
 };
363394
 if( g.interp==0 ){
364395
 int i;
365396
 g.interp = Th_CreateInterp(&vtab);
366397
 th_register_language(g.interp); /* Basic scripting commands. */
367398
--- src/th_main.c
+++ src/th_main.c
@@ -93,10 +93,11 @@
93 }
94 if( g.cgiOutput ){
95 cgi_append_content(z, n);
96 }else{
97 fwrite(z, 1, n, stdout);
 
98 }
99 if( encode ) free((char*)z);
100 }
101 }
102
@@ -334,10 +335,39 @@
334 if( n<iMin ) n = iMin;
335 if( n>iMax ) n = iMax;
336 Th_SetResultInt(interp, n);
337 return TH_OK;
338 }
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
339
340 /*
341 ** Make sure the interpreter has been initialized. Initialize it if
342 ** it has not been already.
343 **
@@ -357,10 +387,11 @@
357 {"htmlize", htmlizeCmd, 0},
358 {"date", dateCmd, 0},
359 {"html", putsCmd, 0},
360 {"puts", putsCmd, (void*)1},
361 {"wiki", wikiCmd, 0},
 
362 };
363 if( g.interp==0 ){
364 int i;
365 g.interp = Th_CreateInterp(&vtab);
366 th_register_language(g.interp); /* Basic scripting commands. */
367
--- src/th_main.c
+++ src/th_main.c
@@ -93,10 +93,11 @@
93 }
94 if( g.cgiOutput ){
95 cgi_append_content(z, n);
96 }else{
97 fwrite(z, 1, n, stdout);
98 fflush(stdout);
99 }
100 if( encode ) free((char*)z);
101 }
102 }
103
@@ -334,10 +335,39 @@
335 if( n<iMin ) n = iMin;
336 if( n>iMax ) n = iMax;
337 Th_SetResultInt(interp, n);
338 return TH_OK;
339 }
340
341 /*
342 ** TH1 command: repository ?BOOLEAN?
343 **
344 ** Return the fully qualified file name of the open repository or an empty
345 ** string if one is not currently open. Optionally, it will attempt to open
346 ** the repository if the boolean argument is non-zero.
347 */
348 static int repositoryCmd(
349 Th_Interp *interp,
350 void *p,
351 int argc,
352 const char **argv,
353 int *argl
354 ){
355 int openRepository;
356
357 if( argc!=1 && argc!=2 ){
358 return Th_WrongNumArgs(interp, "repository ?BOOLEAN?");
359 }
360 if( argc==2 ){
361 if( Th_ToInt(interp, argv[1], argl[1], &openRepository) ){
362 return TH_ERROR;
363 }
364 if( openRepository ) db_find_and_open_repository(OPEN_OK_NOT_FOUND, 0);
365 }
366 Th_SetResult(interp, g.zRepositoryName, -1);
367 return TH_OK;
368 }
369
370 /*
371 ** Make sure the interpreter has been initialized. Initialize it if
372 ** it has not been already.
373 **
@@ -357,10 +387,11 @@
387 {"htmlize", htmlizeCmd, 0},
388 {"date", dateCmd, 0},
389 {"html", putsCmd, 0},
390 {"puts", putsCmd, (void*)1},
391 {"wiki", wikiCmd, 0},
392 {"repository", repositoryCmd, 0},
393 };
394 if( g.interp==0 ){
395 int i;
396 g.interp = Th_CreateInterp(&vtab);
397 th_register_language(g.interp); /* Basic scripting commands. */
398
M src/th_tcl.c
+79 -49
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -3,10 +3,52 @@
33
 */
44
55
 #include "config.h"
66
 #include "th.h"
77
 #include "tcl.h"
8
+
9
+/*
10
+** These macros are designed to reduce the redundant code required to marshal
11
+** arguments from TH1 to Tcl.
12
+ */
13
+#define USE_ARGV_TO_OBJV() \
14
+ int objc; \
15
+ Tcl_Obj **objv; \
16
+ int i;
17
+
18
+#define COPY_ARGV_TO_OBJV() \
19
+ objc = argc-1; \
20
+ objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *))); \
21
+ for(i=1; i<argc; i++){ \
22
+ objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]); \
23
+ Tcl_IncrRefCount(objv[i-1]); \
24
+ }
25
+
26
+#define FREE_ARGV_TO_OBJV() \
27
+ for(i=1; i<argc; i++){ \
28
+ Tcl_DecrRefCount(objv[i-1]); \
29
+ } \
30
+ ckfree((char *)objv);
31
+
32
+/*
33
+** Returns the Tcl interpreter result as a string with the associated length.
34
+** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
35
+** If the length pointer is NULL, the length will not be stored.
36
+ */
37
+static char *getTclResult(Tcl_Interp *pInterp, int *pN){
38
+ Tcl_Obj *resultPtr;
39
+ if( !pInterp ){ /* This should not happen. */
40
+ if( pN ) *pN = 0;
41
+ return 0;
42
+ }
43
+ resultPtr = Tcl_GetObjResult(pInterp);
44
+ if( !resultPtr ){ /* This should not happen either? */
45
+ if( pN ) *pN = 0;
46
+ return 0;
47
+ }
48
+ return Tcl_GetStringFromObj(resultPtr, pN);
49
+}
850
951
 /*
1052
 ** Syntax:
1153
 **
1254
 ** tclEval arg ?arg ...?
@@ -26,39 +68,32 @@
2668
2769
 if( argc<2 ){
2870
 return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
2971
 }
3072
 tclInterp = (Tcl_Interp *)ctx;
31
- if( !tclInterp ){
73
+ if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
3274
 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
3375
 return TH_ERROR;
3476
 }
77
+ Tcl_Preserve((ClientData)tclInterp);
3578
 if( argc==2 ){
3679
 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
3780
 Tcl_IncrRefCount(objPtr);
3881
 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
3982
 Tcl_DecrRefCount(objPtr);
4083
 }else{
41
- int objc = argc-1;
42
- Tcl_Obj **objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
43
- int i;
44
- for(i=1; i<argc; i++){
45
- objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
46
- Tcl_IncrRefCount(objv[i-1]);
47
- }
84
+ USE_ARGV_TO_OBJV();
85
+ COPY_ARGV_TO_OBJV();
4886
 objPtr = Tcl_ConcatObj(objc, objv);
4987
 Tcl_IncrRefCount(objPtr);
5088
 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
5189
 Tcl_DecrRefCount(objPtr);
52
- for(i=1; i<argc; i++){
53
- Tcl_DecrRefCount(objv[i-1]);
54
- }
55
- ckfree((char *)objv);
90
+ FREE_ARGV_TO_OBJV();
5691
 }
57
- objPtr = Tcl_GetObjResult(tclInterp);
58
- zResult = Tcl_GetStringFromObj(objPtr, &nResult);
92
+ zResult = getTclResult(tclInterp, &nResult);
5993
 Th_SetResult(interp, zResult, nResult);
94
+ Tcl_Release((ClientData)tclInterp);
6095
 return rc;
6196
 }
6297
6398
 /*
6499
 ** Syntax:
@@ -81,39 +116,37 @@
81116
82117
 if( argc<2 ){
83118
 return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
84119
 }
85120
 tclInterp = (Tcl_Interp *)ctx;
86
- if( !tclInterp ){
121
+ if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
87122
 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
88123
 return TH_ERROR;
89124
 }
125
+ Tcl_Preserve((ClientData)tclInterp);
90126
 if( argc==2 ){
91127
 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
92128
 Tcl_IncrRefCount(objPtr);
93129
 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
94130
 Tcl_DecrRefCount(objPtr);
95131
 }else{
96
- int objc = argc-1;
97
- Tcl_Obj **objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
98
- int i;
99
- for(i=1; i<argc; i++){
100
- objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
101
- Tcl_IncrRefCount(objv[i-1]);
102
- }
132
+ USE_ARGV_TO_OBJV();
133
+ COPY_ARGV_TO_OBJV();
103134
 objPtr = Tcl_ConcatObj(objc, objv);
104135
 Tcl_IncrRefCount(objPtr);
105136
 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
106137
 Tcl_DecrRefCount(objPtr);
107
- for(i=1; i<argc; i++){
108
- Tcl_DecrRefCount(objv[i-1]);
109
- }
110
- ckfree((char *)objv);
138
+ FREE_ARGV_TO_OBJV();
111139
 }
112
- zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
140
+ if( rc==TCL_OK ){
141
+ zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
142
+ }else{
143
+ zResult = getTclResult(tclInterp, &nResult);
144
+ }
113145
 Th_SetResult(interp, zResult, nResult);
114
- Tcl_DecrRefCount(resultObjPtr);
146
+ if( rc==TCL_OK ) Tcl_DecrRefCount(resultObjPtr);
147
+ Tcl_Release((ClientData)tclInterp);
115148
 return rc;
116149
 }
117150
118151
 /*
119152
 ** Syntax:
@@ -126,46 +159,42 @@
126159
 int argc,
127160
 const char **argv,
128161
 int *argl
129162
 ){
130163
 Tcl_Interp *tclInterp;
164
+ Tcl_Command command;
131165
 Tcl_CmdInfo cmdInfo;
132
- int objc;
133
- Tcl_Obj **objv;
134
- int i;
135166
 int rc;
136167
 int nResult;
137168
 const char *zResult;
138169
 Tcl_Obj *objPtr;
170
+ USE_ARGV_TO_OBJV();
139171
140172
 if( argc<2 ){
141173
 return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
142174
 }
143175
 tclInterp = (Tcl_Interp *)ctx;
144
- if( !tclInterp ){
176
+ if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
145177
 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
146178
 return TH_ERROR;
147179
 }
148
- if (Tcl_GetCommandInfo(tclInterp, argv[1], &cmdInfo) == 0){
180
+ Tcl_Preserve((ClientData)tclInterp);
181
+ objPtr = Tcl_NewStringObj(argv[1], argl[1]);
182
+ Tcl_IncrRefCount(objPtr);
183
+ command = Tcl_GetCommandFromObj(tclInterp, objPtr);
184
+ if( !command || Tcl_GetCommandInfoFromToken(command,&cmdInfo)==0 ){
149185
 Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
186
+ Tcl_DecrRefCount(objPtr);
187
+ Tcl_Release((ClientData)tclInterp);
150188
 return TH_ERROR;
151189
 }
152
- objc = argc-1;
153
- objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
154
- for(i=1; i<argc; i++){
155
- objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
156
- Tcl_IncrRefCount(objv[i-1]);
157
- }
158
- Tcl_Preserve((ClientData)tclInterp);
190
+ Tcl_DecrRefCount(objPtr);
191
+ COPY_ARGV_TO_OBJV();
159192
 Tcl_ResetResult(tclInterp);
160193
 rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
161
- for(i=1; i<argc; i++){
162
- Tcl_DecrRefCount(objv[i-1]);
163
- }
164
- ckfree((char *)objv);
165
- objPtr = Tcl_GetObjResult(tclInterp);
166
- zResult = Tcl_GetStringFromObj(objPtr, &nResult);
194
+ FREE_ARGV_TO_OBJV();
195
+ zResult = getTclResult(tclInterp, &nResult);
167196
 Th_SetResult(interp, zResult, nResult);
168197
 Tcl_Release((ClientData)tclInterp);
169198
 return rc;
170199
 }
171200
@@ -254,11 +283,11 @@
254283
 ClientData clientData,
255284
 Tcl_Interp *interp
256285
 ){
257286
 int i;
258287
 Th_Interp *th1Interp = (Th_Interp *)clientData;
259
- if ( !th1Interp ) return;
288
+ if( !th1Interp ) return;
260289
 /* Remove the Tcl integration commands. */
261290
 for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
262291
 Th_RenameCommand(th1Interp, aCommand[i].zName, -1, NULL, 0);
263292
 }
264293
 }
@@ -269,11 +298,11 @@
269298
 */
270299
 int th_register_tcl(Th_Interp *interp){
271300
 int i;
272301
 Tcl_Interp *tclInterp = Tcl_CreateInterp();
273302
274
- if( !tclInterp ){
303
+ if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
275304
 Th_ErrorMessage(interp,
276305
 "Could not create Tcl interpreter", (const char *)"", 0);
277306
 return TH_ERROR;
278307
 }
279308
 if( Tcl_Init(tclInterp)!=TCL_OK ){
@@ -280,17 +309,18 @@
280309
 Th_ErrorMessage(interp,
281310
 "Tcl initialization error:", Tcl_GetStringResult(tclInterp), -1);
282311
 Tcl_DeleteInterp(tclInterp);
283312
 return TH_ERROR;
284313
 }
314
+ /* Add the TH1 integration commands to Tcl. */
285315
 Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
286316
 Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
287317
 Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
288
- /* Add the Tcl integration commands. */
318
+ /* Add the Tcl integration commands to TH1. */
289319
 for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
290320
 void *ctx = aCommand[i].pContext;
291321
 /* Use Tcl interpreter for context? */
292322
 if( !ctx ) ctx = tclInterp;
293323
 Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
294324
 }
295325
 return TH_OK;
296326
 }
297327
298328
ADDED test/th1-tcl.test
299329
ADDED test/th1-tcl1.txt
300330
ADDED test/th1-tcl2.txt
301331
ADDED test/th1-tcl3.txt
302332
ADDED test/th1-tcl4.txt
303333
ADDED test/th1-tcl5.txt
304334
ADDED test/th1-tcl6.txt
305335
ADDED test/th1-tcl7.txt
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -3,10 +3,52 @@
3 */
4
5 #include "config.h"
6 #include "th.h"
7 #include "tcl.h"
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
8
9 /*
10 ** Syntax:
11 **
12 ** tclEval arg ?arg ...?
@@ -26,39 +68,32 @@
26
27 if( argc<2 ){
28 return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
29 }
30 tclInterp = (Tcl_Interp *)ctx;
31 if( !tclInterp ){
32 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
33 return TH_ERROR;
34 }
 
35 if( argc==2 ){
36 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
37 Tcl_IncrRefCount(objPtr);
38 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
39 Tcl_DecrRefCount(objPtr);
40 }else{
41 int objc = argc-1;
42 Tcl_Obj **objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
43 int i;
44 for(i=1; i<argc; i++){
45 objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
46 Tcl_IncrRefCount(objv[i-1]);
47 }
48 objPtr = Tcl_ConcatObj(objc, objv);
49 Tcl_IncrRefCount(objPtr);
50 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
51 Tcl_DecrRefCount(objPtr);
52 for(i=1; i<argc; i++){
53 Tcl_DecrRefCount(objv[i-1]);
54 }
55 ckfree((char *)objv);
56 }
57 objPtr = Tcl_GetObjResult(tclInterp);
58 zResult = Tcl_GetStringFromObj(objPtr, &nResult);
59 Th_SetResult(interp, zResult, nResult);
 
60 return rc;
61 }
62
63 /*
64 ** Syntax:
@@ -81,39 +116,37 @@
81
82 if( argc<2 ){
83 return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
84 }
85 tclInterp = (Tcl_Interp *)ctx;
86 if( !tclInterp ){
87 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
88 return TH_ERROR;
89 }
 
90 if( argc==2 ){
91 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
92 Tcl_IncrRefCount(objPtr);
93 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
94 Tcl_DecrRefCount(objPtr);
95 }else{
96 int objc = argc-1;
97 Tcl_Obj **objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
98 int i;
99 for(i=1; i<argc; i++){
100 objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
101 Tcl_IncrRefCount(objv[i-1]);
102 }
103 objPtr = Tcl_ConcatObj(objc, objv);
104 Tcl_IncrRefCount(objPtr);
105 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
106 Tcl_DecrRefCount(objPtr);
107 for(i=1; i<argc; i++){
108 Tcl_DecrRefCount(objv[i-1]);
109 }
110 ckfree((char *)objv);
111 }
112 zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
 
 
 
 
113 Th_SetResult(interp, zResult, nResult);
114 Tcl_DecrRefCount(resultObjPtr);
 
115 return rc;
116 }
117
118 /*
119 ** Syntax:
@@ -126,46 +159,42 @@
126 int argc,
127 const char **argv,
128 int *argl
129 ){
130 Tcl_Interp *tclInterp;
 
131 Tcl_CmdInfo cmdInfo;
132 int objc;
133 Tcl_Obj **objv;
134 int i;
135 int rc;
136 int nResult;
137 const char *zResult;
138 Tcl_Obj *objPtr;
 
139
140 if( argc<2 ){
141 return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
142 }
143 tclInterp = (Tcl_Interp *)ctx;
144 if( !tclInterp ){
145 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
146 return TH_ERROR;
147 }
148 if (Tcl_GetCommandInfo(tclInterp, argv[1], &cmdInfo) == 0){
 
 
 
 
149 Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
 
 
150 return TH_ERROR;
151 }
152 objc = argc-1;
153 objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
154 for(i=1; i<argc; i++){
155 objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
156 Tcl_IncrRefCount(objv[i-1]);
157 }
158 Tcl_Preserve((ClientData)tclInterp);
159 Tcl_ResetResult(tclInterp);
160 rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
161 for(i=1; i<argc; i++){
162 Tcl_DecrRefCount(objv[i-1]);
163 }
164 ckfree((char *)objv);
165 objPtr = Tcl_GetObjResult(tclInterp);
166 zResult = Tcl_GetStringFromObj(objPtr, &nResult);
167 Th_SetResult(interp, zResult, nResult);
168 Tcl_Release((ClientData)tclInterp);
169 return rc;
170 }
171
@@ -254,11 +283,11 @@
254 ClientData clientData,
255 Tcl_Interp *interp
256 ){
257 int i;
258 Th_Interp *th1Interp = (Th_Interp *)clientData;
259 if ( !th1Interp ) return;
260 /* Remove the Tcl integration commands. */
261 for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
262 Th_RenameCommand(th1Interp, aCommand[i].zName, -1, NULL, 0);
263 }
264 }
@@ -269,11 +298,11 @@
269 */
270 int th_register_tcl(Th_Interp *interp){
271 int i;
272 Tcl_Interp *tclInterp = Tcl_CreateInterp();
273
274 if( !tclInterp ){
275 Th_ErrorMessage(interp,
276 "Could not create Tcl interpreter", (const char *)"", 0);
277 return TH_ERROR;
278 }
279 if( Tcl_Init(tclInterp)!=TCL_OK ){
@@ -280,17 +309,18 @@
280 Th_ErrorMessage(interp,
281 "Tcl initialization error:", Tcl_GetStringResult(tclInterp), -1);
282 Tcl_DeleteInterp(tclInterp);
283 return TH_ERROR;
284 }
 
285 Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
286 Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
287 Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
288 /* Add the Tcl integration commands. */
289 for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
290 void *ctx = aCommand[i].pContext;
291 /* Use Tcl interpreter for context? */
292 if( !ctx ) ctx = tclInterp;
293 Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
294 }
295 return TH_OK;
296 }
297
298 DDED test/th1-tcl.test
299 DDED test/th1-tcl1.txt
300 DDED test/th1-tcl2.txt
301 DDED test/th1-tcl3.txt
302 DDED test/th1-tcl4.txt
303 DDED test/th1-tcl5.txt
304 DDED test/th1-tcl6.txt
305 DDED test/th1-tcl7.txt
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -3,10 +3,52 @@
3 */
4
5 #include "config.h"
6 #include "th.h"
7 #include "tcl.h"
8
9 /*
10 ** These macros are designed to reduce the redundant code required to marshal
11 ** arguments from TH1 to Tcl.
12 */
13 #define USE_ARGV_TO_OBJV() \
14 int objc; \
15 Tcl_Obj **objv; \
16 int i;
17
18 #define COPY_ARGV_TO_OBJV() \
19 objc = argc-1; \
20 objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *))); \
21 for(i=1; i<argc; i++){ \
22 objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]); \
23 Tcl_IncrRefCount(objv[i-1]); \
24 }
25
26 #define FREE_ARGV_TO_OBJV() \
27 for(i=1; i<argc; i++){ \
28 Tcl_DecrRefCount(objv[i-1]); \
29 } \
30 ckfree((char *)objv);
31
32 /*
33 ** Returns the Tcl interpreter result as a string with the associated length.
34 ** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
35 ** If the length pointer is NULL, the length will not be stored.
36 */
37 static char *getTclResult(Tcl_Interp *pInterp, int *pN){
38 Tcl_Obj *resultPtr;
39 if( !pInterp ){ /* This should not happen. */
40 if( pN ) *pN = 0;
41 return 0;
42 }
43 resultPtr = Tcl_GetObjResult(pInterp);
44 if( !resultPtr ){ /* This should not happen either? */
45 if( pN ) *pN = 0;
46 return 0;
47 }
48 return Tcl_GetStringFromObj(resultPtr, pN);
49 }
50
51 /*
52 ** Syntax:
53 **
54 ** tclEval arg ?arg ...?
@@ -26,39 +68,32 @@
68
69 if( argc<2 ){
70 return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
71 }
72 tclInterp = (Tcl_Interp *)ctx;
73 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
74 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
75 return TH_ERROR;
76 }
77 Tcl_Preserve((ClientData)tclInterp);
78 if( argc==2 ){
79 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
80 Tcl_IncrRefCount(objPtr);
81 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
82 Tcl_DecrRefCount(objPtr);
83 }else{
84 USE_ARGV_TO_OBJV();
85 COPY_ARGV_TO_OBJV();
 
 
 
 
 
86 objPtr = Tcl_ConcatObj(objc, objv);
87 Tcl_IncrRefCount(objPtr);
88 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
89 Tcl_DecrRefCount(objPtr);
90 FREE_ARGV_TO_OBJV();
 
 
 
91 }
92 zResult = getTclResult(tclInterp, &nResult);
 
93 Th_SetResult(interp, zResult, nResult);
94 Tcl_Release((ClientData)tclInterp);
95 return rc;
96 }
97
98 /*
99 ** Syntax:
@@ -81,39 +116,37 @@
116
117 if( argc<2 ){
118 return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
119 }
120 tclInterp = (Tcl_Interp *)ctx;
121 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
122 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
123 return TH_ERROR;
124 }
125 Tcl_Preserve((ClientData)tclInterp);
126 if( argc==2 ){
127 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
128 Tcl_IncrRefCount(objPtr);
129 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
130 Tcl_DecrRefCount(objPtr);
131 }else{
132 USE_ARGV_TO_OBJV();
133 COPY_ARGV_TO_OBJV();
 
 
 
 
 
134 objPtr = Tcl_ConcatObj(objc, objv);
135 Tcl_IncrRefCount(objPtr);
136 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
137 Tcl_DecrRefCount(objPtr);
138 FREE_ARGV_TO_OBJV();
 
 
 
139 }
140 if( rc==TCL_OK ){
141 zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
142 }else{
143 zResult = getTclResult(tclInterp, &nResult);
144 }
145 Th_SetResult(interp, zResult, nResult);
146 if( rc==TCL_OK ) Tcl_DecrRefCount(resultObjPtr);
147 Tcl_Release((ClientData)tclInterp);
148 return rc;
149 }
150
151 /*
152 ** Syntax:
@@ -126,46 +159,42 @@
159 int argc,
160 const char **argv,
161 int *argl
162 ){
163 Tcl_Interp *tclInterp;
164 Tcl_Command command;
165 Tcl_CmdInfo cmdInfo;
 
 
 
166 int rc;
167 int nResult;
168 const char *zResult;
169 Tcl_Obj *objPtr;
170 USE_ARGV_TO_OBJV();
171
172 if( argc<2 ){
173 return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
174 }
175 tclInterp = (Tcl_Interp *)ctx;
176 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
177 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
178 return TH_ERROR;
179 }
180 Tcl_Preserve((ClientData)tclInterp);
181 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
182 Tcl_IncrRefCount(objPtr);
183 command = Tcl_GetCommandFromObj(tclInterp, objPtr);
184 if( !command || Tcl_GetCommandInfoFromToken(command,&cmdInfo)==0 ){
185 Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
186 Tcl_DecrRefCount(objPtr);
187 Tcl_Release((ClientData)tclInterp);
188 return TH_ERROR;
189 }
190 Tcl_DecrRefCount(objPtr);
191 COPY_ARGV_TO_OBJV();
 
 
 
 
 
192 Tcl_ResetResult(tclInterp);
193 rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
194 FREE_ARGV_TO_OBJV();
195 zResult = getTclResult(tclInterp, &nResult);
 
 
 
 
196 Th_SetResult(interp, zResult, nResult);
197 Tcl_Release((ClientData)tclInterp);
198 return rc;
199 }
200
@@ -254,11 +283,11 @@
283 ClientData clientData,
284 Tcl_Interp *interp
285 ){
286 int i;
287 Th_Interp *th1Interp = (Th_Interp *)clientData;
288 if( !th1Interp ) return;
289 /* Remove the Tcl integration commands. */
290 for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
291 Th_RenameCommand(th1Interp, aCommand[i].zName, -1, NULL, 0);
292 }
293 }
@@ -269,11 +298,11 @@
298 */
299 int th_register_tcl(Th_Interp *interp){
300 int i;
301 Tcl_Interp *tclInterp = Tcl_CreateInterp();
302
303 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
304 Th_ErrorMessage(interp,
305 "Could not create Tcl interpreter", (const char *)"", 0);
306 return TH_ERROR;
307 }
308 if( Tcl_Init(tclInterp)!=TCL_OK ){
@@ -280,17 +309,18 @@
309 Th_ErrorMessage(interp,
310 "Tcl initialization error:", Tcl_GetStringResult(tclInterp), -1);
311 Tcl_DeleteInterp(tclInterp);
312 return TH_ERROR;
313 }
314 /* Add the TH1 integration commands to Tcl. */
315 Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
316 Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
317 Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
318 /* Add the Tcl integration commands to TH1. */
319 for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
320 void *ctx = aCommand[i].pContext;
321 /* Use Tcl interpreter for context? */
322 if( !ctx ) ctx = tclInterp;
323 Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
324 }
325 return TH_OK;
326 }
327
328 DDED test/th1-tcl.test
329 DDED test/th1-tcl1.txt
330 DDED test/th1-tcl2.txt
331 DDED test/th1-tcl3.txt
332 DDED test/th1-tcl4.txt
333 DDED test/th1-tcl5.txt
334 DDED test/th1-tcl6.txt
335 DDED test/th1-tcl7.txt
A test/th1-tcl.test
+47
--- a/test/th1-tcl.test
+++ b/test/th1-tcl.test
@@ -0,0 +1,47 @@
1
+; return
2
+}
3
+
4
+h1-tcl3.txt]#
5
+# Copyright (c) 2011 D. Richard Hipp
6
+#
7
+# This progra#
8
+
9
+test_setup
10
+
11
+###############################################################################
12
+
13
+set env(TH1_ENABLE_TCL) 1; # Tcl integration must be enabled for this test.
14
+
15
+###############################################################################
16
+
17
+fossil test-th-render --open-config \
18
+ [file nativename [file join $path th1-tcl1.txt]]
19
+
20
+test tdir th1-tcl1.txt]]
21
+
22
+test th1-tcl-1 {[regexp -- {^tclReady\(before\) = 0
23
+tclReady\(after\) = 1
24
+\d+
25
+\d+
26
+\d+
27
+via Tcl invoke
28
+4
29
+4
30
+two words
31
+one_word
32
+three words now
33
+\d+
34
+two words
35
+4
36
+\d+
37
+two words
38
+4
39
+\d+
40
+one_word
41
+three words now$} [normalize_result]]}
42
+
43
+############################################d+
44
+two words
45
+4
46
+\d+
47
+t
--- a/test/th1-tcl.test
+++ b/test/th1-tcl.test
@@ -0,0 +1,47 @@
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
--- a/test/th1-tcl.test
+++ b/test/th1-tcl.test
@@ -0,0 +1,47 @@
1 ; return
2 }
3
4 h1-tcl3.txt]#
5 # Copyright (c) 2011 D. Richard Hipp
6 #
7 # This progra#
8
9 test_setup
10
11 ###############################################################################
12
13 set env(TH1_ENABLE_TCL) 1; # Tcl integration must be enabled for this test.
14
15 ###############################################################################
16
17 fossil test-th-render --open-config \
18 [file nativename [file join $path th1-tcl1.txt]]
19
20 test tdir th1-tcl1.txt]]
21
22 test th1-tcl-1 {[regexp -- {^tclReady\(before\) = 0
23 tclReady\(after\) = 1
24 \d+
25 \d+
26 \d+
27 via Tcl invoke
28 4
29 4
30 two words
31 one_word
32 three words now
33 \d+
34 two words
35 4
36 \d+
37 two words
38 4
39 \d+
40 one_word
41 three words now$} [normalize_result]]}
42
43 ############################################d+
44 two words
45 4
46 \d+
47 t
A test/th1-tcl1.txt
+22
--- a/test/th1-tcl1.txt
+++ b/test/th1-tcl1.txt
@@ -0,0 +1,22 @@
1
+<th1>
2
+ #
3
+ # This is a "TH1 fragment" used to test the TH1.
4
+ #e e
5
+ # test-script
6
+ set chan test-th-render
7
+ # #
8
+ # This is<th1>
9
+ #
10
+ # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
11
+ # The corresponding test file executes this file using the test-th-render
12
+ # Fossil command.
13
+ #
14
+ proc doOut {msg} {puts $msg; puts \n}
15
+ doOut "tclReady(before) = [tclReady]"
16
+ set channel stdout; tclInvoke set channel $channel
17
+ doOut "tclReady(after) = [tclReady]"
18
+ doOut [tclEval clock seconds]
19
+ dobridgeEval {set y "two words"}]bridgedoOut [set z [tclInvoke th1Expr {2+2}]]
20
+ doOut $x
21
+ doOut $y
22
+ doOut $th1th1
--- a/test/th1-tcl1.txt
+++ b/test/th1-tcl1.txt
@@ -0,0 +1,22 @@
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
--- a/test/th1-tcl1.txt
+++ b/test/th1-tcl1.txt
@@ -0,0 +1,22 @@
1 <th1>
2 #
3 # This is a "TH1 fragment" used to test the TH1.
4 #e e
5 # test-script
6 set chan test-th-render
7 # #
8 # This is<th1>
9 #
10 # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
11 # The corresponding test file executes this file using the test-th-render
12 # Fossil command.
13 #
14 proc doOut {msg} {puts $msg; puts \n}
15 doOut "tclReady(before) = [tclReady]"
16 set channel stdout; tclInvoke set channel $channel
17 doOut "tclReady(after) = [tclReady]"
18 doOut [tclEval clock seconds]
19 dobridgeEval {set y "two words"}]bridgedoOut [set z [tclInvoke th1Expr {2+2}]]
20 doOut $x
21 doOut $y
22 doOut $th1th1
A test/th1-tcl2.txt
+6
--- a/test/th1-tcl2.txt
+++ b/test/th1-tcl2.txt
@@ -0,0 +1,6 @@
1
+<th1>
2
+ #
3
+ # This is a "TH1 fragment" used to test the TH1.
4
+ #e e
5
+ # test-script-rendersing test-th-render
6
+ #
--- a/test/th1-tcl2.txt
+++ b/test/th1-tcl2.txt
@@ -0,0 +1,6 @@
 
 
 
 
 
 
--- a/test/th1-tcl2.txt
+++ b/test/th1-tcl2.txt
@@ -0,0 +1,6 @@
1 <th1>
2 #
3 # This is a "TH1 fragment" used to test the TH1.
4 #e e
5 # test-script-rendersing test-th-render
6 #
A test/th1-tcl3.txt
+9
--- a/test/th1-tcl3.txt
+++ b/test/th1-tcl3.txt
@@ -0,0 +1,9 @@
1
+<th1>
2
+ #
3
+ # This is a "TH1 fragment" used to test the TH1.
4
+ # The corresponding test file e test-th-render
5
+ # the
6
+ # test-script-render Fossil command.
7
+ #
8
+ proc doOut {msg} {puts $msg; puts \n}
9
+ doOut [t
--- a/test/th1-tcl3.txt
+++ b/test/th1-tcl3.txt
@@ -0,0 +1,9 @@
 
 
 
 
 
 
 
 
 
--- a/test/th1-tcl3.txt
+++ b/test/th1-tcl3.txt
@@ -0,0 +1,9 @@
1 <th1>
2 #
3 # This is a "TH1 fragment" used to test the TH1.
4 # The corresponding test file e test-th-render
5 # the
6 # test-script-render Fossil command.
7 #
8 proc doOut {msg} {puts $msg; puts \n}
9 doOut [t
A test/th1-tcl4.txt
+9
--- a/test/th1-tcl4.txt
+++ b/test/th1-tcl4.txt
@@ -0,0 +1,9 @@
1
+<th1>
2
+ #
3
+ # This is a "TH1 fragment" used to test the TH1.
4
+ # The corresponding test file e test-th-render
5
+ # the
6
+ # test-script-render Fossil command.
7
+ #
8
+ proc doOut {msg} {puts $msg; puts \n}
9
+
--- a/test/th1-tcl4.txt
+++ b/test/th1-tcl4.txt
@@ -0,0 +1,9 @@
 
 
 
 
 
 
 
 
 
--- a/test/th1-tcl4.txt
+++ b/test/th1-tcl4.txt
@@ -0,0 +1,9 @@
1 <th1>
2 #
3 # This is a "TH1 fragment" used to test the TH1.
4 # The corresponding test file e test-th-render
5 # the
6 # test-script-render Fossil command.
7 #
8 proc doOut {msg} {puts $msg; puts \n}
9
A test/th1-tcl5.txt
+5
--- a/test/th1-tcl5.txt
+++ b/test/th1-tcl5.txt
@@ -0,0 +1,5 @@
1
+<th1>
2
+ #
3
+ # This is a "TH1 fragment" used to test the TH1.
4
+ # The corresponding test file e test-th-render
5
+ #
--- a/test/th1-tcl5.txt
+++ b/test/th1-tcl5.txt
@@ -0,0 +1,5 @@
 
 
 
 
 
--- a/test/th1-tcl5.txt
+++ b/test/th1-tcl5.txt
@@ -0,0 +1,5 @@
1 <th1>
2 #
3 # This is a "TH1 fragment" used to test the TH1.
4 # The corresponding test file e test-th-render
5 #
A test/th1-tcl6.txt
+9
--- a/test/th1-tcl6.txt
+++ b/test/th1-tcl6.txt
@@ -0,0 +1,9 @@
1
+<th1>
2
+ #
3
+ # This is a "TH1 fragment" used to test the TH1.
4
+ # The corresponding test file e test-th-render
5
+ # the
6
+ # test-script-render Fossil command.
7
+ #
8
+ proc doOut {msg} {puts $msg;th1Eval bad_command]
9
+</th1>
--- a/test/th1-tcl6.txt
+++ b/test/th1-tcl6.txt
@@ -0,0 +1,9 @@
 
 
 
 
 
 
 
 
 
--- a/test/th1-tcl6.txt
+++ b/test/th1-tcl6.txt
@@ -0,0 +1,9 @@
1 <th1>
2 #
3 # This is a "TH1 fragment" used to test the TH1.
4 # The corresponding test file e test-th-render
5 # the
6 # test-script-render Fossil command.
7 #
8 proc doOut {msg} {puts $msg;th1Eval bad_command]
9 </th1>
A test/th1-tcl7.txt
+18
--- a/test/th1-tcl7.txt
+++ b/test/th1-tcl7.txt
@@ -0,0 +1,18 @@
1
+<th1>
2
+ #
3
+ # This is a "TH1 fragment" used to test the TH1.
4
+ # The corresponding test file e test-th-render
5
+ # the
6
+ # test-script-render Fossil command.
7
+ #
8
+ proc doOut {msg} {puts $msg; puts \n}
9
+
10
+ #
11
+ # BUGBUG: Attempting to divide by zero will crash TH1 with the error:
12
+ # "child killed: floating-point exceptith1Expr 2/0]
13
+
14
+ #
15
+ # NOTE: For now, just cause an expression syntax error.
16
+ #
17
+ doOut [tclEval th1Expr 2**0]
18
+</th1>
--- a/test/th1-tcl7.txt
+++ b/test/th1-tcl7.txt
@@ -0,0 +1,18 @@
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
--- a/test/th1-tcl7.txt
+++ b/test/th1-tcl7.txt
@@ -0,0 +1,18 @@
1 <th1>
2 #
3 # This is a "TH1 fragment" used to test the TH1.
4 # The corresponding test file e test-th-render
5 # the
6 # test-script-render Fossil command.
7 #
8 proc doOut {msg} {puts $msg; puts \n}
9
10 #
11 # BUGBUG: Attempting to divide by zero will crash TH1 with the error:
12 # "child killed: floating-point exceptith1Expr 2/0]
13
14 #
15 # NOTE: For now, just cause an expression syntax error.
16 #
17 doOut [tclEval th1Expr 2**0]
18 </th1>

Keyboard Shortcuts

Open search /
Next entry (timeline) j
Previous entry (timeline) k
Open focused entry Enter
Show this help ?
Toggle theme Top nav button