Fossil SCM

Enhance Tcl integration with support for notifications before and after Tcl scripts are evaluated.

mistachkin 2012-10-07 13:55 trunk
Commit 49c63f8c78a38b4632a1c4255078c5b6e9ec5f30
Parent fa4e828653c9b06…
3 files changed +4 +80 -11 +1 -1
~ src/main.c ~ src/th_tcl.c ~ test/th1-tcl2.txt
M src/main.c
+4
--- src/main.c
+++ src/main.c
@@ -95,10 +95,14 @@
9595
 void *library; /* The Tcl library module handle. */
9696
 void *xFindExecutable; /* See tcl_FindExecutableProc in th_tcl.c. */
9797
 void *xCreateInterp; /* See tcl_CreateInterpProc in th_tcl.c. */
9898
 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
9999
 char *setup; /* The optional Tcl setup script. */
100
+ void *xPreEval; /* Optional, called before Tcl_Eval*(). */
101
+ void *pPreContext; /* Optional, provided to xPreEval(). */
102
+ void *xPostEval; /* Optional, called after Tcl_Eval*(). */
103
+ void *pPostContext; /* Optional, provided to xPostEval(). */
100104
 };
101105
 #endif
102106
103107
 /*
104108
 ** All global variables are in this structure.
105109
--- src/main.c
+++ src/main.c
@@ -95,10 +95,14 @@
95 void *library; /* The Tcl library module handle. */
96 void *xFindExecutable; /* See tcl_FindExecutableProc in th_tcl.c. */
97 void *xCreateInterp; /* See tcl_CreateInterpProc in th_tcl.c. */
98 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
99 char *setup; /* The optional Tcl setup script. */
 
 
 
 
100 };
101 #endif
102
103 /*
104 ** All global variables are in this structure.
105
--- src/main.c
+++ src/main.c
@@ -95,10 +95,14 @@
95 void *library; /* The Tcl library module handle. */
96 void *xFindExecutable; /* See tcl_FindExecutableProc in th_tcl.c. */
97 void *xCreateInterp; /* See tcl_CreateInterpProc in th_tcl.c. */
98 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
99 char *setup; /* The optional Tcl setup script. */
100 void *xPreEval; /* Optional, called before Tcl_Eval*(). */
101 void *pPreContext; /* Optional, provided to xPreEval(). */
102 void *xPostEval; /* Optional, called after Tcl_Eval*(). */
103 void *pPostContext; /* Optional, provided to xPostEval(). */
104 };
105 #endif
106
107 /*
108 ** All global variables are in this structure.
109
M src/th_tcl.c
+80 -11
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -80,17 +80,17 @@
8080
 # endif
8181
 # ifndef TCL_MINOR_OFFSET
8282
 # define TCL_MINOR_OFFSET (4)
8383
 # endif
8484
 # ifndef dlopen
85
-# define dlopen(a,b) (void *)LoadLibrary((a));
85
+# define dlopen(a,b) (void *)LoadLibrary((a))
8686
 # endif
8787
 # ifndef dlsym
88
-# define dlsym(a,b) GetProcAddress((HANDLE)(a),(b));
88
+# define dlsym(a,b) GetProcAddress((HANDLE)(a),(b))
8989
 # endif
9090
 # ifndef dlclose
91
-# define dlclose(a) FreeLibrary((HANDLE)(a));
91
+# define dlclose(a) FreeLibrary((HANDLE)(a))
9292
 # endif
9393
 # else
9494
 # include <dlfcn.h>
9595
 # if defined(__CYGWIN__)
9696
 # ifndef TCL_LIBRARY_NAME
@@ -122,18 +122,36 @@
122122
 # define TCL_CREATEINTERP_NAME "_Tcl_CreateInterp"
123123
 # endif
124124
 #endif /* defined(USE_TCL_STUBS) */
125125
126126
 /*
127
-** The function pointer types for Tcl_FindExecutable and Tcl_CreateInterp are
128
-** needed when the Tcl library is being loaded dynamically by a stubs-enabled
127
+** The function types for Tcl_FindExecutable and Tcl_CreateInterp are needed
128
+** when the Tcl library is being loaded dynamically by a stubs-enabled
129129
 ** application (i.e. the inverse of using a stubs-enabled package). These are
130130
 ** the only Tcl API functions that MUST be called prior to being able to call
131131
 ** Tcl_InitStubs (i.e. because it requires a Tcl interpreter).
132132
 */
133133
 typedef void (tcl_FindExecutableProc) (CONST char * argv0);
134134
 typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
135
+
136
+/*
137
+** The function types for the "hook" functions to be called before and after a
138
+** TH1 command makes a call to evaluate a Tcl script. If the "pre" function
139
+** returns anything but TH_OK, then evaluation of the Tcl script is skipped and
140
+** that value is used as the return code. If the "post" function returns
141
+** anything other than its rc argument, that will become the new return code
142
+** for the command.
143
+ */
144
+typedef int (tcl_NotifyProc) (
145
+ void *pContext, /* The context for this notification. */
146
+ Th_Interp *interp, /* The TH1 interpreter being used. */
147
+ void *ctx, /* The original TH1 command context. */
148
+ int argc, /* Number of arguments for the TH1 command. */
149
+ const char **argv, /* Array of arguments for the TH1 command. */
150
+ int *argl, /* Array of lengths for the TH1 command arguments. */
151
+ int rc /* Recommended notification return value. */
152
+);
135153
136154
 /*
137155
 ** Creates and initializes a Tcl interpreter for use with the specified TH1
138156
 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
139157
 ** by the caller. This must be declared here because quite a few functions in
@@ -173,11 +191,47 @@
173191
 void *library; /* The Tcl library module handle. */
174192
 tcl_FindExecutableProc *xFindExecutable; /* Tcl_FindExecutable() pointer. */
175193
 tcl_CreateInterpProc *xCreateInterp; /* Tcl_CreateInterp() pointer. */
176194
 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
177195
 char *setup; /* The optional Tcl setup script. */
196
+ tcl_NotifyProc *xPreEval; /* Optional, called before Tcl_Eval*(). */
197
+ void *pPreContext; /* Optional, provided to xPreEval(). */
198
+ tcl_NotifyProc *xPostEval; /* Optional, called after Tcl_Eval*(). */
199
+ void *pPostContext; /* Optional, provided to xPostEval(). */
178200
 };
201
+
202
+/*
203
+** This function calls the configured xPreEval or xPostEval functions, if any.
204
+** May have arbitrary side-effects. This function returns the result of the
205
+** called notification function or the value of the rc argument if there is no
206
+** notification function configured.
207
+*/
208
+static int notifyPreOrPostEval(
209
+ int bIsPost,
210
+ Th_Interp *interp,
211
+ void *ctx,
212
+ int argc,
213
+ const char **argv,
214
+ int *argl,
215
+ int rc
216
+){
217
+ struct TclContext *tclContext = (struct TclContext *)ctx;
218
+ tcl_NotifyProc *xNotifyProc;
219
+
220
+ if ( !tclContext ){
221
+ Th_ErrorMessage(interp,
222
+ "Invalid Tcl context", (const char *)"", 0);
223
+ return TH_ERROR;
224
+ }
225
+ xNotifyProc = bIsPost ? tclContext->xPostEval : tclContext->xPreEval;
226
+ if ( xNotifyProc ){
227
+ rc = xNotifyProc(bIsPost ?
228
+ tclContext->pPostContext : tclContext->pPreContext,
229
+ interp, ctx, argc, argv, argl, rc);
230
+ }
231
+ return rc;
232
+}
179233
180234
 /*
181235
 ** Syntax:
182236
 **
183237
 ** tclEval arg ?arg ...?
@@ -189,24 +243,28 @@
189243
 const char **argv,
190244
 int *argl
191245
 ){
192246
 Tcl_Interp *tclInterp;
193247
 Tcl_Obj *objPtr;
194
- int rc;
248
+ int rc = TH_OK;
195249
 int nResult;
196250
 const char *zResult;
197251
198
- if ( createTclInterp(interp, ctx)!=TH_OK ){
252
+ if( createTclInterp(interp, ctx)!=TH_OK ){
199253
 return TH_ERROR;
200254
 }
201255
 if( argc<2 ){
202256
 return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
203257
 }
204258
 tclInterp = GET_CTX_TCL_INTERP(ctx);
205259
 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
206260
 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
207261
 return TH_ERROR;
262
+ }
263
+ rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
264
+ if( rc!=TH_OK ){
265
+ return rc;
208266
 }
209267
 Tcl_Preserve((ClientData)tclInterp);
210268
 if( argc==2 ){
211269
 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
212270
 Tcl_IncrRefCount(objPtr);
@@ -222,10 +280,11 @@
222280
 FREE_ARGV_TO_OBJV();
223281
 }
224282
 zResult = getTclResult(tclInterp, &nResult);
225283
 Th_SetResult(interp, zResult, nResult);
226284
 Tcl_Release((ClientData)tclInterp);
285
+ rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
227286
 return rc;
228287
 }
229288
230289
 /*
231290
 ** Syntax:
@@ -240,24 +299,28 @@
240299
 int *argl
241300
 ){
242301
 Tcl_Interp *tclInterp;
243302
 Tcl_Obj *objPtr;
244303
 Tcl_Obj *resultObjPtr;
245
- int rc;
304
+ int rc = TH_OK;
246305
 int nResult;
247306
 const char *zResult;
248307
249
- if ( createTclInterp(interp, ctx)!=TH_OK ){
308
+ if( createTclInterp(interp, ctx)!=TH_OK ){
250309
 return TH_ERROR;
251310
 }
252311
 if( argc<2 ){
253312
 return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
254313
 }
255314
 tclInterp = GET_CTX_TCL_INTERP(ctx);
256315
 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
257316
 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
258317
 return TH_ERROR;
318
+ }
319
+ rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
320
+ if( rc!=TH_OK ){
321
+ return rc;
259322
 }
260323
 Tcl_Preserve((ClientData)tclInterp);
261324
 if( argc==2 ){
262325
 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
263326
 Tcl_IncrRefCount(objPtr);
@@ -278,10 +341,11 @@
278341
 zResult = getTclResult(tclInterp, &nResult);
279342
 }
280343
 Th_SetResult(interp, zResult, nResult);
281344
 if( rc==TCL_OK ) Tcl_DecrRefCount(resultObjPtr);
282345
 Tcl_Release((ClientData)tclInterp);
346
+ rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
283347
 return rc;
284348
 }
285349
286350
 /*
287351
 ** Syntax:
@@ -298,28 +362,32 @@
298362
 Tcl_Interp *tclInterp;
299363
 #if !defined(USE_TCL_EVALOBJV)
300364
 Tcl_Command command;
301365
 Tcl_CmdInfo cmdInfo;
302366
 #endif
303
- int rc;
367
+ int rc = TH_OK;
304368
 int nResult;
305369
 const char *zResult;
306370
 #if !defined(USE_TCL_EVALOBJV)
307371
 Tcl_Obj *objPtr;
308372
 #endif
309373
 USE_ARGV_TO_OBJV();
310374
311
- if ( createTclInterp(interp, ctx)!=TH_OK ){
375
+ if( createTclInterp(interp, ctx)!=TH_OK ){
312376
 return TH_ERROR;
313377
 }
314378
 if( argc<2 ){
315379
 return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
316380
 }
317381
 tclInterp = GET_CTX_TCL_INTERP(ctx);
318382
 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
319383
 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
320384
 return TH_ERROR;
385
+ }
386
+ rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
387
+ if( rc!=TH_OK ){
388
+ return rc;
321389
 }
322390
 Tcl_Preserve((ClientData)tclInterp);
323391
 #if !defined(USE_TCL_EVALOBJV)
324392
 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
325393
 Tcl_IncrRefCount(objPtr);
@@ -347,10 +415,11 @@
347415
 #endif
348416
 FREE_ARGV_TO_OBJV();
349417
 zResult = getTclResult(tclInterp, &nResult);
350418
 Th_SetResult(interp, zResult, nResult);
351419
 Tcl_Release((ClientData)tclInterp);
420
+ rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
352421
 return rc;
353422
 }
354423
355424
 /*
356425
 ** Syntax:
357426
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -80,17 +80,17 @@
80 # endif
81 # ifndef TCL_MINOR_OFFSET
82 # define TCL_MINOR_OFFSET (4)
83 # endif
84 # ifndef dlopen
85 # define dlopen(a,b) (void *)LoadLibrary((a));
86 # endif
87 # ifndef dlsym
88 # define dlsym(a,b) GetProcAddress((HANDLE)(a),(b));
89 # endif
90 # ifndef dlclose
91 # define dlclose(a) FreeLibrary((HANDLE)(a));
92 # endif
93 # else
94 # include <dlfcn.h>
95 # if defined(__CYGWIN__)
96 # ifndef TCL_LIBRARY_NAME
@@ -122,18 +122,36 @@
122 # define TCL_CREATEINTERP_NAME "_Tcl_CreateInterp"
123 # endif
124 #endif /* defined(USE_TCL_STUBS) */
125
126 /*
127 ** The function pointer types for Tcl_FindExecutable and Tcl_CreateInterp are
128 ** needed when the Tcl library is being loaded dynamically by a stubs-enabled
129 ** application (i.e. the inverse of using a stubs-enabled package). These are
130 ** the only Tcl API functions that MUST be called prior to being able to call
131 ** Tcl_InitStubs (i.e. because it requires a Tcl interpreter).
132 */
133 typedef void (tcl_FindExecutableProc) (CONST char * argv0);
134 typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
135
136 /*
137 ** Creates and initializes a Tcl interpreter for use with the specified TH1
138 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
139 ** by the caller. This must be declared here because quite a few functions in
@@ -173,11 +191,47 @@
173 void *library; /* The Tcl library module handle. */
174 tcl_FindExecutableProc *xFindExecutable; /* Tcl_FindExecutable() pointer. */
175 tcl_CreateInterpProc *xCreateInterp; /* Tcl_CreateInterp() pointer. */
176 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
177 char *setup; /* The optional Tcl setup script. */
 
 
 
 
178 };
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
179
180 /*
181 ** Syntax:
182 **
183 ** tclEval arg ?arg ...?
@@ -189,24 +243,28 @@
189 const char **argv,
190 int *argl
191 ){
192 Tcl_Interp *tclInterp;
193 Tcl_Obj *objPtr;
194 int rc;
195 int nResult;
196 const char *zResult;
197
198 if ( createTclInterp(interp, ctx)!=TH_OK ){
199 return TH_ERROR;
200 }
201 if( argc<2 ){
202 return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
203 }
204 tclInterp = GET_CTX_TCL_INTERP(ctx);
205 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
206 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
207 return TH_ERROR;
 
 
 
 
208 }
209 Tcl_Preserve((ClientData)tclInterp);
210 if( argc==2 ){
211 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
212 Tcl_IncrRefCount(objPtr);
@@ -222,10 +280,11 @@
222 FREE_ARGV_TO_OBJV();
223 }
224 zResult = getTclResult(tclInterp, &nResult);
225 Th_SetResult(interp, zResult, nResult);
226 Tcl_Release((ClientData)tclInterp);
 
227 return rc;
228 }
229
230 /*
231 ** Syntax:
@@ -240,24 +299,28 @@
240 int *argl
241 ){
242 Tcl_Interp *tclInterp;
243 Tcl_Obj *objPtr;
244 Tcl_Obj *resultObjPtr;
245 int rc;
246 int nResult;
247 const char *zResult;
248
249 if ( createTclInterp(interp, ctx)!=TH_OK ){
250 return TH_ERROR;
251 }
252 if( argc<2 ){
253 return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
254 }
255 tclInterp = GET_CTX_TCL_INTERP(ctx);
256 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
257 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
258 return TH_ERROR;
 
 
 
 
259 }
260 Tcl_Preserve((ClientData)tclInterp);
261 if( argc==2 ){
262 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
263 Tcl_IncrRefCount(objPtr);
@@ -278,10 +341,11 @@
278 zResult = getTclResult(tclInterp, &nResult);
279 }
280 Th_SetResult(interp, zResult, nResult);
281 if( rc==TCL_OK ) Tcl_DecrRefCount(resultObjPtr);
282 Tcl_Release((ClientData)tclInterp);
 
283 return rc;
284 }
285
286 /*
287 ** Syntax:
@@ -298,28 +362,32 @@
298 Tcl_Interp *tclInterp;
299 #if !defined(USE_TCL_EVALOBJV)
300 Tcl_Command command;
301 Tcl_CmdInfo cmdInfo;
302 #endif
303 int rc;
304 int nResult;
305 const char *zResult;
306 #if !defined(USE_TCL_EVALOBJV)
307 Tcl_Obj *objPtr;
308 #endif
309 USE_ARGV_TO_OBJV();
310
311 if ( createTclInterp(interp, ctx)!=TH_OK ){
312 return TH_ERROR;
313 }
314 if( argc<2 ){
315 return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
316 }
317 tclInterp = GET_CTX_TCL_INTERP(ctx);
318 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
319 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
320 return TH_ERROR;
 
 
 
 
321 }
322 Tcl_Preserve((ClientData)tclInterp);
323 #if !defined(USE_TCL_EVALOBJV)
324 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
325 Tcl_IncrRefCount(objPtr);
@@ -347,10 +415,11 @@
347 #endif
348 FREE_ARGV_TO_OBJV();
349 zResult = getTclResult(tclInterp, &nResult);
350 Th_SetResult(interp, zResult, nResult);
351 Tcl_Release((ClientData)tclInterp);
 
352 return rc;
353 }
354
355 /*
356 ** Syntax:
357
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -80,17 +80,17 @@
80 # endif
81 # ifndef TCL_MINOR_OFFSET
82 # define TCL_MINOR_OFFSET (4)
83 # endif
84 # ifndef dlopen
85 # define dlopen(a,b) (void *)LoadLibrary((a))
86 # endif
87 # ifndef dlsym
88 # define dlsym(a,b) GetProcAddress((HANDLE)(a),(b))
89 # endif
90 # ifndef dlclose
91 # define dlclose(a) FreeLibrary((HANDLE)(a))
92 # endif
93 # else
94 # include <dlfcn.h>
95 # if defined(__CYGWIN__)
96 # ifndef TCL_LIBRARY_NAME
@@ -122,18 +122,36 @@
122 # define TCL_CREATEINTERP_NAME "_Tcl_CreateInterp"
123 # endif
124 #endif /* defined(USE_TCL_STUBS) */
125
126 /*
127 ** The function types for Tcl_FindExecutable and Tcl_CreateInterp are needed
128 ** when the Tcl library is being loaded dynamically by a stubs-enabled
129 ** application (i.e. the inverse of using a stubs-enabled package). These are
130 ** the only Tcl API functions that MUST be called prior to being able to call
131 ** Tcl_InitStubs (i.e. because it requires a Tcl interpreter).
132 */
133 typedef void (tcl_FindExecutableProc) (CONST char * argv0);
134 typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
135
136 /*
137 ** The function types for the "hook" functions to be called before and after a
138 ** TH1 command makes a call to evaluate a Tcl script. If the "pre" function
139 ** returns anything but TH_OK, then evaluation of the Tcl script is skipped and
140 ** that value is used as the return code. If the "post" function returns
141 ** anything other than its rc argument, that will become the new return code
142 ** for the command.
143 */
144 typedef int (tcl_NotifyProc) (
145 void *pContext, /* The context for this notification. */
146 Th_Interp *interp, /* The TH1 interpreter being used. */
147 void *ctx, /* The original TH1 command context. */
148 int argc, /* Number of arguments for the TH1 command. */
149 const char **argv, /* Array of arguments for the TH1 command. */
150 int *argl, /* Array of lengths for the TH1 command arguments. */
151 int rc /* Recommended notification return value. */
152 );
153
154 /*
155 ** Creates and initializes a Tcl interpreter for use with the specified TH1
156 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
157 ** by the caller. This must be declared here because quite a few functions in
@@ -173,11 +191,47 @@
191 void *library; /* The Tcl library module handle. */
192 tcl_FindExecutableProc *xFindExecutable; /* Tcl_FindExecutable() pointer. */
193 tcl_CreateInterpProc *xCreateInterp; /* Tcl_CreateInterp() pointer. */
194 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
195 char *setup; /* The optional Tcl setup script. */
196 tcl_NotifyProc *xPreEval; /* Optional, called before Tcl_Eval*(). */
197 void *pPreContext; /* Optional, provided to xPreEval(). */
198 tcl_NotifyProc *xPostEval; /* Optional, called after Tcl_Eval*(). */
199 void *pPostContext; /* Optional, provided to xPostEval(). */
200 };
201
202 /*
203 ** This function calls the configured xPreEval or xPostEval functions, if any.
204 ** May have arbitrary side-effects. This function returns the result of the
205 ** called notification function or the value of the rc argument if there is no
206 ** notification function configured.
207 */
208 static int notifyPreOrPostEval(
209 int bIsPost,
210 Th_Interp *interp,
211 void *ctx,
212 int argc,
213 const char **argv,
214 int *argl,
215 int rc
216 ){
217 struct TclContext *tclContext = (struct TclContext *)ctx;
218 tcl_NotifyProc *xNotifyProc;
219
220 if ( !tclContext ){
221 Th_ErrorMessage(interp,
222 "Invalid Tcl context", (const char *)"", 0);
223 return TH_ERROR;
224 }
225 xNotifyProc = bIsPost ? tclContext->xPostEval : tclContext->xPreEval;
226 if ( xNotifyProc ){
227 rc = xNotifyProc(bIsPost ?
228 tclContext->pPostContext : tclContext->pPreContext,
229 interp, ctx, argc, argv, argl, rc);
230 }
231 return rc;
232 }
233
234 /*
235 ** Syntax:
236 **
237 ** tclEval arg ?arg ...?
@@ -189,24 +243,28 @@
243 const char **argv,
244 int *argl
245 ){
246 Tcl_Interp *tclInterp;
247 Tcl_Obj *objPtr;
248 int rc = TH_OK;
249 int nResult;
250 const char *zResult;
251
252 if( createTclInterp(interp, ctx)!=TH_OK ){
253 return TH_ERROR;
254 }
255 if( argc<2 ){
256 return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
257 }
258 tclInterp = GET_CTX_TCL_INTERP(ctx);
259 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
260 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
261 return TH_ERROR;
262 }
263 rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
264 if( rc!=TH_OK ){
265 return rc;
266 }
267 Tcl_Preserve((ClientData)tclInterp);
268 if( argc==2 ){
269 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
270 Tcl_IncrRefCount(objPtr);
@@ -222,10 +280,11 @@
280 FREE_ARGV_TO_OBJV();
281 }
282 zResult = getTclResult(tclInterp, &nResult);
283 Th_SetResult(interp, zResult, nResult);
284 Tcl_Release((ClientData)tclInterp);
285 rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
286 return rc;
287 }
288
289 /*
290 ** Syntax:
@@ -240,24 +299,28 @@
299 int *argl
300 ){
301 Tcl_Interp *tclInterp;
302 Tcl_Obj *objPtr;
303 Tcl_Obj *resultObjPtr;
304 int rc = TH_OK;
305 int nResult;
306 const char *zResult;
307
308 if( createTclInterp(interp, ctx)!=TH_OK ){
309 return TH_ERROR;
310 }
311 if( argc<2 ){
312 return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
313 }
314 tclInterp = GET_CTX_TCL_INTERP(ctx);
315 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
316 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
317 return TH_ERROR;
318 }
319 rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
320 if( rc!=TH_OK ){
321 return rc;
322 }
323 Tcl_Preserve((ClientData)tclInterp);
324 if( argc==2 ){
325 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
326 Tcl_IncrRefCount(objPtr);
@@ -278,10 +341,11 @@
341 zResult = getTclResult(tclInterp, &nResult);
342 }
343 Th_SetResult(interp, zResult, nResult);
344 if( rc==TCL_OK ) Tcl_DecrRefCount(resultObjPtr);
345 Tcl_Release((ClientData)tclInterp);
346 rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
347 return rc;
348 }
349
350 /*
351 ** Syntax:
@@ -298,28 +362,32 @@
362 Tcl_Interp *tclInterp;
363 #if !defined(USE_TCL_EVALOBJV)
364 Tcl_Command command;
365 Tcl_CmdInfo cmdInfo;
366 #endif
367 int rc = TH_OK;
368 int nResult;
369 const char *zResult;
370 #if !defined(USE_TCL_EVALOBJV)
371 Tcl_Obj *objPtr;
372 #endif
373 USE_ARGV_TO_OBJV();
374
375 if( createTclInterp(interp, ctx)!=TH_OK ){
376 return TH_ERROR;
377 }
378 if( argc<2 ){
379 return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
380 }
381 tclInterp = GET_CTX_TCL_INTERP(ctx);
382 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
383 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
384 return TH_ERROR;
385 }
386 rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
387 if( rc!=TH_OK ){
388 return rc;
389 }
390 Tcl_Preserve((ClientData)tclInterp);
391 #if !defined(USE_TCL_EVALOBJV)
392 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
393 Tcl_IncrRefCount(objPtr);
@@ -347,10 +415,11 @@
415 #endif
416 FREE_ARGV_TO_OBJV();
417 zResult = getTclResult(tclInterp, &nResult);
418 Th_SetResult(interp, zResult, nResult);
419 Tcl_Release((ClientData)tclInterp);
420 rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
421 return rc;
422 }
423
424 /*
425 ** Syntax:
426
M test/th1-tcl2.txt
+1 -1
--- test/th1-tcl2.txt
+++ test/th1-tcl2.txt
@@ -9,11 +9,11 @@
99
 #
1010
 tclInvoke set repository_name [repository 1]
1111
 proc doOut {msg} {puts $msg; puts \n}
1212
 doOut [tclEval {
1313
 package require sqlite3
14
- sqlite3 db $repository_name
14
+ sqlite3 db $repository_name -readonly true
1515
 set x [db eval {SELECT COUNT(*) FROM user;}]
1616
 db close
1717
 return $x
1818
 }]
1919
 </th1>
2020
--- test/th1-tcl2.txt
+++ test/th1-tcl2.txt
@@ -9,11 +9,11 @@
9 #
10 tclInvoke set repository_name [repository 1]
11 proc doOut {msg} {puts $msg; puts \n}
12 doOut [tclEval {
13 package require sqlite3
14 sqlite3 db $repository_name
15 set x [db eval {SELECT COUNT(*) FROM user;}]
16 db close
17 return $x
18 }]
19 </th1>
20
--- test/th1-tcl2.txt
+++ test/th1-tcl2.txt
@@ -9,11 +9,11 @@
9 #
10 tclInvoke set repository_name [repository 1]
11 proc doOut {msg} {puts $msg; puts \n}
12 doOut [tclEval {
13 package require sqlite3
14 sqlite3 db $repository_name -readonly true
15 set x [db eval {SELECT COUNT(*) FROM user;}]
16 db close
17 return $x
18 }]
19 </th1>
20

Keyboard Shortcuts

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