Fossil SCM

Add ability to evaluate Tcl expressions from TH1. Add ability to invoke Tcl commands from TH1. Add the ability to evaluate TH1 scripts and expressions from Tcl.

mistachkin 2011-08-27 16:26 tcl-integration
Commit c5a6e9ea694d45aabe2790c21f32185d9acac972
Parent f723647710ef07c…
1 file changed +222 -24
~ src/th_tcl.c
M src/th_tcl.c
+222 -24
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -7,43 +7,42 @@
77
 #include "tcl.h"
88
99
 /*
1010
 ** Syntax:
1111
 **
12
-** tclEval script
12
+** tclEval arg ?arg ...?
1313
 */
1414
 static int tclEval_command(
1515
 Th_Interp *interp,
1616
 void *ctx,
1717
 int argc,
1818
 const char **argv,
1919
 int *argl
2020
 ){
21
- Tcl_Interp *tclInterp = (Tcl_Interp *)ctx;
21
+ Tcl_Interp *tclInterp;
2222
 Tcl_Obj *objPtr;
2323
 int rc;
2424
 int nResult;
2525
 const char *zResult;
2626
2727
 if( argc<2 ){
2828
 return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
2929
 }
30
-
31
- if( !ctx ){
30
+ tclInterp = (Tcl_Interp *)ctx;
31
+ if( !tclInterp ){
3232
 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
3333
 return TH_ERROR;
3434
 }
35
-
3635
 if( argc==2 ){
3736
 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
3837
 Tcl_IncrRefCount(objPtr);
3938
 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
4039
 Tcl_DecrRefCount(objPtr);
4140
 }else{
42
- int i;
4341
 int objc = argc-1;
44
- Tcl_Obj **objv = ckalloc((unsigned) (objc * sizeof(Tcl_Obj *)));
42
+ Tcl_Obj **objv = ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
43
+ int i;
4544
 for(i=1; i<argc; i++){
4645
 objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
4746
 Tcl_IncrRefCount(objv[i-1]);
4847
 }
4948
 objPtr = Tcl_ConcatObj(objc, objv);
@@ -51,39 +50,235 @@
5150
 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
5251
 Tcl_DecrRefCount(objPtr);
5352
 for(i=1; i<argc; i++){
5453
 Tcl_DecrRefCount(objv[i-1]);
5554
 }
56
- ckfree(objv);
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:
65
+**
66
+** tclExpr arg ?arg ...?
67
+*/
68
+static int tclExpr_command(
69
+ Th_Interp *interp,
70
+ void *ctx,
71
+ int argc,
72
+ const char **argv,
73
+ int *argl
74
+){
75
+ Tcl_Interp *tclInterp;
76
+ Tcl_Obj *objPtr;
77
+ Tcl_Obj *resultObjPtr;
78
+ int rc;
79
+ int nResult;
80
+ const char *zResult;
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 = 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);
57111
 }
112
+ zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
113
+ Tcl_DecrRefCount(resultObjPtr);
114
+ Th_SetResult(interp, zResult, nResult);
115
+ return rc;
116
+}
117
+
118
+/*
119
+** Syntax:
120
+**
121
+** tclInvoke command ?arg ...?
122
+*/
123
+static int tclInvoke_command(
124
+ Th_Interp *interp,
125
+ void *ctx,
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;
58139
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 = 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
+ rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
160
+ for(i=1; i<argc; i++){
161
+ Tcl_DecrRefCount(objv[i-1]);
162
+ }
163
+ ckfree((char *)objv);
59164
 objPtr = Tcl_GetObjResult(tclInterp);
60165
 zResult = Tcl_GetStringFromObj(objPtr, &nResult);
166
+ Tcl_Release((ClientData)tclInterp);
61167
 Th_SetResult(interp, zResult, nResult);
62
- return TH_OK;
168
+ return rc;
169
+}
170
+
171
+/*
172
+** Syntax:
173
+**
174
+** th1Eval arg
175
+*/
176
+static int Th1EvalObjCmd(
177
+ ClientData clientData,
178
+ Tcl_Interp *interp,
179
+ int objc,
180
+ Tcl_Obj *CONST objv[]
181
+){
182
+ Th_Interp *th1Interp = (Th_Interp *)clientData;
183
+ int nArg;
184
+ const char *arg;
185
+ int rc;
186
+
187
+ if( objc!=2 ){
188
+ Tcl_WrongNumArgs(interp, 1, objv, "arg");
189
+ return TCL_ERROR;
190
+ }
191
+
192
+ if( !th1Interp ){
193
+ Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
194
+ return TCL_ERROR;
195
+ }
196
+
197
+ arg = Tcl_GetStringFromObj(objv[1], &nArg);
198
+ rc = Th_Eval(th1Interp, 0, arg, nArg);
199
+ arg = Th_GetResult(th1Interp, &nArg);
200
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
201
+ return rc;
202
+}
203
+
204
+/*
205
+** Syntax:
206
+**
207
+** th1Expr arg
208
+*/
209
+static int Th1ExprObjCmd(
210
+ ClientData clientData,
211
+ Tcl_Interp *interp,
212
+ int objc,
213
+ Tcl_Obj *CONST objv[]
214
+){
215
+ Th_Interp *th1Interp = (Th_Interp *)clientData;
216
+ int nArg;
217
+ const char *arg;
218
+ int rc;
219
+
220
+ if( objc!=2 ){
221
+ Tcl_WrongNumArgs(interp, 1, objv, "arg");
222
+ return TCL_ERROR;
223
+ }
224
+
225
+ if( !th1Interp ){
226
+ Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
227
+ return TCL_ERROR;
228
+ }
229
+
230
+ arg = Tcl_GetStringFromObj(objv[1], &nArg);
231
+ rc = Th_Expr(th1Interp, arg, nArg);
232
+ arg = Th_GetResult(th1Interp, &nArg);
233
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
234
+ return rc;
235
+}
236
+
237
+/*
238
+** Array of Tcl integration commands. Used when adding or removing the Tcl
239
+** integration commands from TH1.
240
+*/
241
+static struct _Command {
242
+ const char *zName;
243
+ Th_CommandProc xProc;
244
+ void *pContext;
245
+} aCommand[] = {
246
+ {"tclEval", tclEval_command, 0},
247
+ {"tclExpr", tclExpr_command, 0},
248
+ {"tclInvoke", tclInvoke_command, 0},
249
+ {0, 0, 0}
250
+};
251
+
252
+/*
253
+** Called if the Tcl interpreter is deleted. Removes the Tcl integration
254
+** commands from the TH1 interpreter.
255
+ */
256
+static void Th1DeleteProc(
257
+ ClientData clientData,
258
+ Tcl_Interp *interp
259
+){
260
+ int i;
261
+ Th_Interp *th1Interp = (Th_Interp *)clientData;
262
+ if ( !th1Interp ) return;
263
+ /* Remove the Tcl integration commands. */
264
+ for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
265
+ Th_RenameCommand(th1Interp, aCommand[i].zName, -1, NULL, 0);
266
+ }
63267
 }
64268
65269
 /*
66270
 ** Register the Tcl language commands with interpreter interp.
67271
 ** Usually this is called soon after interpreter creation.
68272
 */
69273
 int th_register_tcl(Th_Interp *interp){
70
- /* Array of Tcl commands. */
71
- struct _Command {
72
- const char *zName;
73
- Th_CommandProc xProc;
74
- void *pContext;
75
- } aCommand[] = {
76
- {"tclEval", tclEval_command, 0},
77
- /* {"tclExpr", tclExpr_command, 0}, */
78
- /* {"tclInvoke", tclInvoke_command, 0}, */
79
- {0, 0, 0}
80
- };
81274
 int i;
82275
 Tcl_Interp *tclInterp = Tcl_CreateInterp();
83276
84277
 if( !tclInterp ){
278
+ Th_ErrorMessage(interp,
279
+ "Could not create Tcl interpreter", (const char *)"", 0);
85280
 return TH_ERROR;
86281
 }
87282
88283
 if( Tcl_Init(tclInterp)!=TCL_OK ){
89284
 Th_ErrorMessage(interp,
@@ -90,16 +285,19 @@
90285
 "Tcl initialization error:", Tcl_GetStringResult(tclInterp), -1);
91286
 Tcl_DeleteInterp(tclInterp);
92287
 return TH_ERROR;
93288
 }
94289
95
- /* Add the language commands. */
290
+ Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
291
+ Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
292
+ Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
293
+
294
+ /* Add the Tcl integration commands. */
96295
 for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
97296
 void *ctx = aCommand[i].pContext;
98
- if( !ctx ){
99
- ctx = tclInterp; /* NOTE: Use Tcl interpreter for context. */
100
- }
297
+ /* Use Tcl interpreter for context? */
298
+ if( !ctx ) ctx = tclInterp;
101299
 Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
102300
 }
103301
104302
 return TH_OK;
105303
 }
106304
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -7,43 +7,42 @@
7 #include "tcl.h"
8
9 /*
10 ** Syntax:
11 **
12 ** tclEval script
13 */
14 static int tclEval_command(
15 Th_Interp *interp,
16 void *ctx,
17 int argc,
18 const char **argv,
19 int *argl
20 ){
21 Tcl_Interp *tclInterp = (Tcl_Interp *)ctx;
22 Tcl_Obj *objPtr;
23 int rc;
24 int nResult;
25 const char *zResult;
26
27 if( argc<2 ){
28 return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
29 }
30
31 if( !ctx ){
32 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
33 return TH_ERROR;
34 }
35
36 if( argc==2 ){
37 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
38 Tcl_IncrRefCount(objPtr);
39 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
40 Tcl_DecrRefCount(objPtr);
41 }else{
42 int i;
43 int objc = argc-1;
44 Tcl_Obj **objv = ckalloc((unsigned) (objc * sizeof(Tcl_Obj *)));
 
45 for(i=1; i<argc; i++){
46 objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
47 Tcl_IncrRefCount(objv[i-1]);
48 }
49 objPtr = Tcl_ConcatObj(objc, objv);
@@ -51,39 +50,235 @@
51 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
52 Tcl_DecrRefCount(objPtr);
53 for(i=1; i<argc; i++){
54 Tcl_DecrRefCount(objv[i-1]);
55 }
56 ckfree(objv);
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
57 }
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
58
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
59 objPtr = Tcl_GetObjResult(tclInterp);
60 zResult = Tcl_GetStringFromObj(objPtr, &nResult);
 
61 Th_SetResult(interp, zResult, nResult);
62 return TH_OK;
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
63 }
64
65 /*
66 ** Register the Tcl language commands with interpreter interp.
67 ** Usually this is called soon after interpreter creation.
68 */
69 int th_register_tcl(Th_Interp *interp){
70 /* Array of Tcl commands. */
71 struct _Command {
72 const char *zName;
73 Th_CommandProc xProc;
74 void *pContext;
75 } aCommand[] = {
76 {"tclEval", tclEval_command, 0},
77 /* {"tclExpr", tclExpr_command, 0}, */
78 /* {"tclInvoke", tclInvoke_command, 0}, */
79 {0, 0, 0}
80 };
81 int i;
82 Tcl_Interp *tclInterp = Tcl_CreateInterp();
83
84 if( !tclInterp ){
 
 
85 return TH_ERROR;
86 }
87
88 if( Tcl_Init(tclInterp)!=TCL_OK ){
89 Th_ErrorMessage(interp,
@@ -90,16 +285,19 @@
90 "Tcl initialization error:", Tcl_GetStringResult(tclInterp), -1);
91 Tcl_DeleteInterp(tclInterp);
92 return TH_ERROR;
93 }
94
95 /* Add the language commands. */
 
 
 
 
96 for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
97 void *ctx = aCommand[i].pContext;
98 if( !ctx ){
99 ctx = tclInterp; /* NOTE: Use Tcl interpreter for context. */
100 }
101 Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
102 }
103
104 return TH_OK;
105 }
106
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -7,43 +7,42 @@
7 #include "tcl.h"
8
9 /*
10 ** Syntax:
11 **
12 ** tclEval arg ?arg ...?
13 */
14 static int tclEval_command(
15 Th_Interp *interp,
16 void *ctx,
17 int argc,
18 const char **argv,
19 int *argl
20 ){
21 Tcl_Interp *tclInterp;
22 Tcl_Obj *objPtr;
23 int rc;
24 int nResult;
25 const char *zResult;
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 = 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);
@@ -51,39 +50,235 @@
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:
65 **
66 ** tclExpr arg ?arg ...?
67 */
68 static int tclExpr_command(
69 Th_Interp *interp,
70 void *ctx,
71 int argc,
72 const char **argv,
73 int *argl
74 ){
75 Tcl_Interp *tclInterp;
76 Tcl_Obj *objPtr;
77 Tcl_Obj *resultObjPtr;
78 int rc;
79 int nResult;
80 const char *zResult;
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 = 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 Tcl_DecrRefCount(resultObjPtr);
114 Th_SetResult(interp, zResult, nResult);
115 return rc;
116 }
117
118 /*
119 ** Syntax:
120 **
121 ** tclInvoke command ?arg ...?
122 */
123 static int tclInvoke_command(
124 Th_Interp *interp,
125 void *ctx,
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 = 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 rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
160 for(i=1; i<argc; i++){
161 Tcl_DecrRefCount(objv[i-1]);
162 }
163 ckfree((char *)objv);
164 objPtr = Tcl_GetObjResult(tclInterp);
165 zResult = Tcl_GetStringFromObj(objPtr, &nResult);
166 Tcl_Release((ClientData)tclInterp);
167 Th_SetResult(interp, zResult, nResult);
168 return rc;
169 }
170
171 /*
172 ** Syntax:
173 **
174 ** th1Eval arg
175 */
176 static int Th1EvalObjCmd(
177 ClientData clientData,
178 Tcl_Interp *interp,
179 int objc,
180 Tcl_Obj *CONST objv[]
181 ){
182 Th_Interp *th1Interp = (Th_Interp *)clientData;
183 int nArg;
184 const char *arg;
185 int rc;
186
187 if( objc!=2 ){
188 Tcl_WrongNumArgs(interp, 1, objv, "arg");
189 return TCL_ERROR;
190 }
191
192 if( !th1Interp ){
193 Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
194 return TCL_ERROR;
195 }
196
197 arg = Tcl_GetStringFromObj(objv[1], &nArg);
198 rc = Th_Eval(th1Interp, 0, arg, nArg);
199 arg = Th_GetResult(th1Interp, &nArg);
200 Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
201 return rc;
202 }
203
204 /*
205 ** Syntax:
206 **
207 ** th1Expr arg
208 */
209 static int Th1ExprObjCmd(
210 ClientData clientData,
211 Tcl_Interp *interp,
212 int objc,
213 Tcl_Obj *CONST objv[]
214 ){
215 Th_Interp *th1Interp = (Th_Interp *)clientData;
216 int nArg;
217 const char *arg;
218 int rc;
219
220 if( objc!=2 ){
221 Tcl_WrongNumArgs(interp, 1, objv, "arg");
222 return TCL_ERROR;
223 }
224
225 if( !th1Interp ){
226 Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
227 return TCL_ERROR;
228 }
229
230 arg = Tcl_GetStringFromObj(objv[1], &nArg);
231 rc = Th_Expr(th1Interp, arg, nArg);
232 arg = Th_GetResult(th1Interp, &nArg);
233 Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
234 return rc;
235 }
236
237 /*
238 ** Array of Tcl integration commands. Used when adding or removing the Tcl
239 ** integration commands from TH1.
240 */
241 static struct _Command {
242 const char *zName;
243 Th_CommandProc xProc;
244 void *pContext;
245 } aCommand[] = {
246 {"tclEval", tclEval_command, 0},
247 {"tclExpr", tclExpr_command, 0},
248 {"tclInvoke", tclInvoke_command, 0},
249 {0, 0, 0}
250 };
251
252 /*
253 ** Called if the Tcl interpreter is deleted. Removes the Tcl integration
254 ** commands from the TH1 interpreter.
255 */
256 static void Th1DeleteProc(
257 ClientData clientData,
258 Tcl_Interp *interp
259 ){
260 int i;
261 Th_Interp *th1Interp = (Th_Interp *)clientData;
262 if ( !th1Interp ) return;
263 /* Remove the Tcl integration commands. */
264 for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
265 Th_RenameCommand(th1Interp, aCommand[i].zName, -1, NULL, 0);
266 }
267 }
268
269 /*
270 ** Register the Tcl language commands with interpreter interp.
271 ** Usually this is called soon after interpreter creation.
272 */
273 int th_register_tcl(Th_Interp *interp){
 
 
 
 
 
 
 
 
 
 
 
274 int i;
275 Tcl_Interp *tclInterp = Tcl_CreateInterp();
276
277 if( !tclInterp ){
278 Th_ErrorMessage(interp,
279 "Could not create Tcl interpreter", (const char *)"", 0);
280 return TH_ERROR;
281 }
282
283 if( Tcl_Init(tclInterp)!=TCL_OK ){
284 Th_ErrorMessage(interp,
@@ -90,16 +285,19 @@
285 "Tcl initialization error:", Tcl_GetStringResult(tclInterp), -1);
286 Tcl_DeleteInterp(tclInterp);
287 return TH_ERROR;
288 }
289
290 Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
291 Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
292 Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
293
294 /* Add the Tcl integration commands. */
295 for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
296 void *ctx = aCommand[i].pContext;
297 /* Use Tcl interpreter for context? */
298 if( !ctx ) ctx = tclInterp;
 
299 Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
300 }
301
302 return TH_OK;
303 }
304

Keyboard Shortcuts

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