1 /*
2 ** Copyright (c) 2011 D. Richard Hipp
3 ** Copyright (c) 2011 Joe Mistachkin
4 **
5 ** This program is free software; you can redistribute it and/or
6 ** modify it under the terms of the Simplified BSD License (also
7 ** known as the "2-Clause License" or "FreeBSD License".)
8
9 ** This program is distributed in the hope that it will be useful,
10 ** but without any warranty; without even the implied warranty of
11 ** merchantability or fitness for a particular purpose.
12 **
13 ** Author contact information:
14 ** drh@hwaci.com
15 ** http://www.hwaci.com/drh/
16 **
17 *******************************************************************************
18 **
19 ** This file contains code used to bridge the TH1 and Tcl scripting languages.
20 */
21 #include "config.h"
22
23 #ifdef FOSSIL_ENABLE_TCL
24
25 #include "sqlite3.h"
26 #include "th.h"
27 #include "tcl.h"
28
29 /*
30 ** This macro is used to verify that the header version of Tcl meets some
31 ** minimum requirement.
32 */
33 #define MINIMUM_TCL_VERSION(major, minor) \
34 ((TCL_MAJOR_VERSION > (major)) || \
35 ((TCL_MAJOR_VERSION == (major)) && (TCL_MINOR_VERSION >= (minor))))
36
37 /*
38 ** These macros are designed to reduce the redundant code required to marshal
39 ** arguments from TH1 to Tcl.
40 */
41 #define USE_ARGV_TO_OBJV() \
42 int objc; \
43 Tcl_Obj **objv; \
44 int obji;
45
46 #define COPY_ARGV_TO_OBJV() \
47 objc = argc-1; \
48 objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *))); \
49 for(obji=1; obji<argc; obji++){ \
50 objv[obji-1] = Tcl_NewStringObj(argv[obji], argl[obji]); \
51 Tcl_IncrRefCount(objv[obji-1]); \
52 }
53
54 #define FREE_ARGV_TO_OBJV() \
55 for(obji=1; obji<argc; obji++){ \
56 Tcl_DecrRefCount(objv[obji-1]); \
57 objv[obji-1] = 0; \
58 } \
59 ckfree((char *)objv); \
60 objv = 0;
61
62 /*
63 ** Fetch the Tcl interpreter from the specified void pointer, cast to a Tcl
64 ** context.
65 */
66 #define GET_CTX_TCL_INTERP(ctx) \
67 ((struct TclContext *)(ctx))->interp
68
69 /*
70 ** Fetch the (logically boolean) value from the specified void pointer that
71 ** indicates whether or not we can/should use direct objProc calls.
72 */
73 #define GET_CTX_TCL_USEOBJPROC(ctx) \
74 ((struct TclContext *)(ctx))->useObjProc
75
76 /*
77 ** This is the name of an environment variable that may refer to a Tcl library
78 ** directory or file name. If this environment variable is set [to anything],
79 ** its value will be used when searching for a Tcl library to load.
80 */
81 #ifndef TCL_PATH_ENV_VAR_NAME
82 # define TCL_PATH_ENV_VAR_NAME "FOSSIL_TCL_PATH"
83 #endif
84
85 /*
86 ** Define the Tcl shared library name, some exported function names, and some
87 ** cross-platform macros for use with the Tcl stubs mechanism, when enabled.
88 */
89 #if defined(USE_TCL_STUBS)
90 # if defined(_WIN32)
91 # if !defined(WIN32_LEAN_AND_MEAN)
92 # define WIN32_LEAN_AND_MEAN
93 # endif
94 # if !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0502)
95 # undef _WIN32_WINNT
96 # define _WIN32_WINNT 0x0502 /* SetDllDirectory, Windows XP SP2 */
97 # endif
98 # include <windows.h>
99 # ifndef TCL_DIRECTORY_SEP
100 # define TCL_DIRECTORY_SEP '\\'
101 # endif
102 # ifndef TCL_LIBRARY_NAME
103 # define TCL_LIBRARY_NAME "tcl87.dll\0"
104 # endif
105 # ifndef TCL_MINOR_OFFSET
106 # define TCL_MINOR_OFFSET (4)
107 # endif
108 # ifndef dlopen
109 # define dlopen(a,b) (void *)LoadLibrary((a))
110 # endif
111 # ifndef dlsym
112 # define dlsym(a,b) GetProcAddress((HANDLE)(a),(b))
113 # endif
114 # ifndef dlclose
115 # define dlclose(a) FreeLibrary((HANDLE)(a))
116 # endif
117 # else
118 # include <dlfcn.h>
119 # ifndef TCL_DIRECTORY_SEP
120 # define TCL_DIRECTORY_SEP '/'
121 # endif
122 # if defined(__CYGWIN__)
123 # ifndef TCL_LIBRARY_NAME
124 # define TCL_LIBRARY_NAME "libtcl8.7.dll\0"
125 # endif
126 # ifndef TCL_MINOR_OFFSET
127 # define TCL_MINOR_OFFSET (8)
128 # endif
129 # elif defined(__APPLE__)
130 # ifndef TCL_LIBRARY_NAME
131 # define TCL_LIBRARY_NAME "libtcl8.7.dylib\0"
132 # endif
133 # ifndef TCL_MINOR_OFFSET
134 # define TCL_MINOR_OFFSET (8)
135 # endif
136 # elif defined(__FreeBSD__)
137 # ifndef TCL_LIBRARY_NAME
138 # define TCL_LIBRARY_NAME "libtcl87.so\0"
139 # endif
140 # ifndef TCL_MINOR_OFFSET
141 # define TCL_MINOR_OFFSET (7)
142 # endif
143 # else
144 # ifndef TCL_LIBRARY_NAME
145 # define TCL_LIBRARY_NAME "libtcl8.7.so\0"
146 # endif
147 # ifndef TCL_MINOR_OFFSET
148 # define TCL_MINOR_OFFSET (8)
149 # endif
150 # endif /* defined(__CYGWIN__) */
151 # endif /* defined(_WIN32) */
152 # ifndef TCL_FINDEXECUTABLE_NAME
153 # define TCL_FINDEXECUTABLE_NAME "_Tcl_FindExecutable\0"
154 # endif
155 # ifndef TCL_CREATEINTERP_NAME
156 # define TCL_CREATEINTERP_NAME "_Tcl_CreateInterp\0"
157 # endif
158 # ifndef TCL_DELETEINTERP_NAME
159 # define TCL_DELETEINTERP_NAME "_Tcl_DeleteInterp\0"
160 # endif
161 # ifndef TCL_FINALIZE_NAME
162 # define TCL_FINALIZE_NAME "_Tcl_Finalize\0"
163 # endif
164 #endif /* defined(USE_TCL_STUBS) */
165
166 /*
167 ** If this constant is defined to non-zero, the Win32 SetDllDirectory function
168 ** will be used during the Tcl library loading process if the path environment
169 ** variable for Tcl was set.
170 */
171 #ifndef TCL_USE_SET_DLL_DIRECTORY
172 # if defined(_WIN32) && defined(_WIN32_WINNT) && (_WIN32_WINNT >= 0x0502)
173 # define TCL_USE_SET_DLL_DIRECTORY (1)
174 # else
175 # define TCL_USE_SET_DLL_DIRECTORY (0)
176 # endif
177 #endif /* TCL_USE_SET_DLL_DIRECTORY */
178
179 /*
180 ** The function types for Tcl_FindExecutable and Tcl_CreateInterp are needed
181 ** when the Tcl library is being loaded dynamically by a stubs-enabled
182 ** application (i.e. the inverse of using a stubs-enabled package). These are
183 ** the only Tcl API functions that MUST be called prior to being able to call
184 ** Tcl_InitStubs (i.e. because it requires a Tcl interpreter). For complete
185 ** cleanup if the Tcl stubs initialization fails somehow, the Tcl_DeleteInterp
186 ** and Tcl_Finalize function types are also required.
187 */
188 typedef void (tcl_FindExecutableProc) (const char *);
189 typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
190 typedef void (tcl_DeleteInterpProc) (Tcl_Interp *);
191 typedef void (tcl_FinalizeProc) (void);
192
193 /*
194 ** The function types for the "hook" functions to be called before and after a
195 ** TH1 command makes a call to evaluate a Tcl script. If the "pre" function
196 ** returns anything but TH_OK, then evaluation of the Tcl script is skipped and
197 ** that value is used as the return code. If the "post" function returns
198 ** anything other than its rc argument, that will become the new return code
199 ** for the command.
200 */
201 typedef int (tcl_NotifyProc) (
202 void *pContext, /* The context for this notification. */
203 Th_Interp *interp, /* The TH1 interpreter being used. */
204 void *ctx, /* The original TH1 command context. */
205 int argc, /* Number of arguments for the TH1 command. */
206 const char **argv, /* Array of arguments for the TH1 command. */
207 int *argl, /* Array of lengths for the TH1 command arguments. */
208 int rc /* Recommended notification return value. */
209 );
210
211 /*
212 ** Are we using our own private implementation of the Tcl stubs mechanism? If
213 ** this is enabled, it prevents the user from having to link against the Tcl
214 ** stubs library for the target platform, which may not be readily available.
215 */
216 #if defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS)
217 /*
218 ** HACK: Using some preprocessor magic and a private static variable, redirect
219 ** the Tcl API calls [found within this file] to the function pointers
220 ** that will be contained in our private Tcl stubs table. This takes
221 ** advantage of the fact that the Tcl headers always define the Tcl API
222 ** functions in terms of the "tclStubsPtr" variable when the define
223 ** USE_TCL_STUBS is present during compilation.
224 */
225 #define tclStubsPtr privateTclStubsPtr
226 static const TclStubs *tclStubsPtr = NULL;
227
228 /*
229 ** Create a Tcl interpreter structure that mirrors just enough fields to get
230 ** it up and running successfully with our private implementation of the Tcl
231 ** stubs mechanism.
232 */
233 struct PrivateTclInterp {
234 char *result;
235 Tcl_FreeProc *freeProc;
236 int errorLine;
237 const struct TclStubs *stubTable;
238 };
239
240 /*
241 ** Fossil can now be compiled without linking to the actual Tcl stubs library.
242 ** In that case, this function will be used to perform those steps that would
243 ** normally be performed within the Tcl stubs library.
244 */
initTclStubs(Th_Interp * interp,Tcl_Interp * tclInterp)245 static int initTclStubs(
246 Th_Interp *interp,
247 Tcl_Interp *tclInterp
248 ){
249 tclStubsPtr = ((struct PrivateTclInterp *)tclInterp)->stubTable;
250 if( !tclStubsPtr || (tclStubsPtr->magic!=TCL_STUB_MAGIC) ){
251 Th_ErrorMessage(interp,
252 "could not initialize Tcl stubs: incompatible mechanism",
253 (const char *)"", 0);
254 return TH_ERROR;
255 }
256 /* NOTE: At this point, the Tcl API functions should be available. */
257 if( Tcl_PkgRequireEx(tclInterp, "Tcl", "8.4", 0, (void *)&tclStubsPtr)==0 ){
258 Th_ErrorMessage(interp,
259 "could not initialize Tcl stubs: incompatible version",
260 (const char *)"", 0);
261 return TH_ERROR;
262 }
263 return TH_OK;
264 }
265 #endif /* defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS) */
266
267 /*
268 ** Is the loaded version of Tcl one where querying and/or calling the objProc
269 ** for a command does not work for some reason? The following special cases
270 ** are currently handled by this function:
271 **
272 ** 1. All versions of Tcl 8.4 have a bug that causes a crash when calling into
273 ** the Tcl_GetCommandFromObj function via stubs (i.e. the stubs table entry
274 ** is NULL).
275 **
276 ** 2. Various beta builds of Tcl 8.6, namely 1 and 2, have an NRE-specific bug
277 ** in Tcl_EvalObjCmd (SF bug #3399564) that cause a panic when calling into
278 ** the objProc directly.
279 **
280 ** For both of the above cases, the Tcl_EvalObjv function must be used instead
281 ** of the more direct route of querying and calling the objProc directly.
282 */
canUseObjProc()283 static int canUseObjProc(){
284 int major = -1, minor = -1, patchLevel = -1, type = -1;
285
286 Tcl_GetVersion(&major, &minor, &patchLevel, &type);
287 if( major<0 || minor<0 || patchLevel<0 || type<0 ){
288 return 0; /* NOTE: Invalid version info, assume bad. */
289 }
290 if( major==8 && minor==4 ){
291 return 0; /* NOTE: Disabled on Tcl 8.4, missing public API. */
292 }
293 if( major==8 && minor==6 && type==TCL_BETA_RELEASE && patchLevel<3 ){
294 return 0; /* NOTE: Disabled on Tcl 8.6b1/b2, SF bug #3399564. */
295 }
296 return 1; /* NOTE: For all other cases, assume good. */
297 }
298
299 /*
300 ** Is the loaded version of Tcl one where TIP #285 (asynchronous script
301 ** cancellation) is available? This should return non-zero only for Tcl
302 ** 8.6 and higher.
303 */
canUseTip285()304 static int canUseTip285(){
305 #if MINIMUM_TCL_VERSION(8, 6)
306 int major = -1, minor = -1, patchLevel = -1, type = -1;
307
308 Tcl_GetVersion(&major, &minor, &patchLevel, &type);
309 if( major<0 || minor<0 || patchLevel<0 || type<0 ){
310 return 0; /* NOTE: Invalid version info, assume bad. */
311 }
312 return (major>8 || (major==8 && minor>=6));
313 #else
314 return 0;
315 #endif
316 }
317
318 /*
319 ** Creates and initializes a Tcl interpreter for use with the specified TH1
320 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
321 ** by the caller. This must be declared here because quite a few functions in
322 ** this file need to use it before it can be defined.
323 */
324 static int createTclInterp(Th_Interp *interp, void *pContext);
325
326 /*
327 ** Returns the TH1 return code corresponding to the specified Tcl
328 ** return code.
329 */
getTh1ReturnCode(int rc)330 static int getTh1ReturnCode(
331 int rc /* The Tcl return code value to convert. */
332 ){
333 switch( rc ){
334 case /*0*/ TCL_OK: return /*0*/ TH_OK;
335 case /*1*/ TCL_ERROR: return /*1*/ TH_ERROR;
336 case /*2*/ TCL_RETURN: return /*3*/ TH_RETURN;
337 case /*3*/ TCL_BREAK: return /*2*/ TH_BREAK;
338 case /*4*/ TCL_CONTINUE: return /*4*/ TH_CONTINUE;
339 default /*?*/: return /*?*/ rc;
340 }
341 }
342
343 /*
344 ** Returns the Tcl return code corresponding to the specified TH1
345 ** return code.
346 */
getTclReturnCode(int rc)347 static int getTclReturnCode(
348 int rc /* The TH1 return code value to convert. */
349 ){
350 switch( rc ){
351 case /*0*/ TH_OK: return /*0*/ TCL_OK;
352 case /*1*/ TH_ERROR: return /*1*/ TCL_ERROR;
353 case /*2*/ TH_BREAK: return /*3*/ TCL_BREAK;
354 case /*3*/ TH_RETURN: return /*2*/ TCL_RETURN;
355 case /*4*/ TH_CONTINUE: return /*4*/ TCL_CONTINUE;
356 default /*?*/: return /*?*/ rc;
357 }
358 }
359
360 /*
361 ** Returns a name for a Tcl return code.
362 */
getTclReturnCodeName(int rc,int nullIfOk)363 static const char *getTclReturnCodeName(
364 int rc,
365 int nullIfOk
366 ){
367 static char zRc[TCL_INTEGER_SPACE + 17]; /* "Tcl return code\0" */
368
369 switch( rc ){
370 case TCL_OK: return nullIfOk ? 0 : "TCL_OK";
371 case TCL_ERROR: return "TCL_ERROR";
372 case TCL_RETURN: return "TCL_RETURN";
373 case TCL_BREAK: return "TCL_BREAK";
374 case TCL_CONTINUE: return "TCL_CONTINUE";
375 default: {
376 sqlite3_snprintf(sizeof(zRc), zRc, "Tcl return code %d", rc);
377 }
378 }
379 return zRc;
380 }
381
382 /*
383 ** Returns the Tcl interpreter result as a string with the associated length.
384 ** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
385 ** If the length pointer is NULL, the length will not be stored.
386 */
getTclResult(Tcl_Interp * pInterp,int * pN)387 static char *getTclResult(
388 Tcl_Interp *pInterp,
389 int *pN
390 ){
391 Tcl_Obj *resultPtr;
392
393 if( !pInterp ){ /* This should not happen. */
394 if( pN ) *pN = 0;
395 return 0;
396 }
397 resultPtr = Tcl_GetObjResult(pInterp);
398 if( !resultPtr ){ /* This should not happen either? */
399 if( pN ) *pN = 0;
400 return 0;
401 }
402 return Tcl_GetStringFromObj(resultPtr, pN);
403 }
404
405 /*
406 ** Tcl context information used by TH1. This structure definition has been
407 ** copied from and should be kept in sync with the one in "main.c".
408 */
409 struct TclContext {
410 int argc; /* Number of original arguments. */
411 char **argv; /* Full copy of the original arguments. */
412 void *hLibrary; /* The Tcl library module handle. */
413 tcl_FindExecutableProc *xFindExecutable; /* Tcl_FindExecutable() pointer. */
414 tcl_CreateInterpProc *xCreateInterp; /* Tcl_CreateInterp() pointer. */
415 tcl_DeleteInterpProc *xDeleteInterp; /* Tcl_DeleteInterp() pointer. */
416 tcl_FinalizeProc *xFinalize; /* Tcl_Finalize() pointer. */
417 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
418 int useObjProc; /* Non-zero if an objProc can be called directly. */
419 int useTip285; /* Non-zero if TIP #285 is available. */
420 const char *setup; /* The optional Tcl setup script. */
421 tcl_NotifyProc *xPreEval; /* Optional, called before Tcl_Eval*(). */
422 void *pPreContext; /* Optional, provided to xPreEval(). */
423 tcl_NotifyProc *xPostEval; /* Optional, called after Tcl_Eval*(). */
424 void *pPostContext; /* Optional, provided to xPostEval(). */
425 };
426
427 /*
428 ** This function calls the configured xPreEval or xPostEval functions, if any.
429 ** May have arbitrary side-effects. This function returns the result of the
430 ** called notification function or the value of the rc argument if there is no
431 ** notification function configured.
432 */
notifyPreOrPostEval(int bIsPost,Th_Interp * interp,void * ctx,int argc,const char ** argv,int * argl,int rc)433 static int notifyPreOrPostEval(
434 int bIsPost,
435 Th_Interp *interp,
436 void *ctx,
437 int argc,
438 const char **argv,
439 int *argl,
440 int rc
441 ){
442 struct TclContext *tclContext = (struct TclContext *)ctx;
443 tcl_NotifyProc *xNotifyProc;
444
445 if( !tclContext ){
446 Th_ErrorMessage(interp,
447 "invalid Tcl context", (const char *)"", 0);
448 return TH_ERROR;
449 }
450 xNotifyProc = bIsPost ? tclContext->xPostEval : tclContext->xPreEval;
451 if( xNotifyProc ){
452 rc = xNotifyProc(bIsPost ?
453 tclContext->pPostContext : tclContext->pPreContext,
454 interp, ctx, argc, argv, argl, rc);
455 }
456 return rc;
457 }
458
459 /*
460 ** TH1 command: tclEval arg ?arg ...?
461 **
462 ** Evaluates the Tcl script and returns its result verbatim. If a Tcl script
463 ** error is generated, it will be transformed into a TH1 script error. The
464 ** Tcl interpreter will be created automatically if it has not been already.
465 */
tclEval_command(Th_Interp * interp,void * ctx,int argc,const char ** argv,int * argl)466 static int tclEval_command(
467 Th_Interp *interp,
468 void *ctx,
469 int argc,
470 const char **argv,
471 int *argl
472 ){
473 Tcl_Interp *tclInterp;
474 Tcl_Obj *objPtr;
475 int rc = TH_OK;
476 int nResult;
477 const char *zResult;
478
479 if( createTclInterp(interp, ctx)!=TH_OK ){
480 return TH_ERROR;
481 }
482 if( argc<2 ){
483 return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
484 }
485 tclInterp = GET_CTX_TCL_INTERP(ctx);
486 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
487 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
488 return TH_ERROR;
489 }
490 rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
491 if( rc!=TH_OK ){
492 return rc;
493 }
494 Tcl_Preserve((ClientData)tclInterp);
495 if( argc==2 ){
496 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
497 Tcl_IncrRefCount(objPtr);
498 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
499 Tcl_DecrRefCount(objPtr); objPtr = 0;
500 }else{
501 USE_ARGV_TO_OBJV();
502 COPY_ARGV_TO_OBJV();
503 objPtr = Tcl_ConcatObj(objc, objv);
504 Tcl_IncrRefCount(objPtr);
505 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
506 Tcl_DecrRefCount(objPtr); objPtr = 0;
507 FREE_ARGV_TO_OBJV();
508 }
509 zResult = getTclResult(tclInterp, &nResult);
510 Th_SetResult(interp, zResult, nResult);
511 Tcl_Release((ClientData)tclInterp);
512 rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl,
513 getTh1ReturnCode(rc));
514 return rc;
515 }
516
517 /*
518 ** TH1 command: tclExpr arg ?arg ...?
519 **
520 ** Evaluates the Tcl expression and returns its result verbatim. If a Tcl
521 ** script error is generated, it will be transformed into a TH1 script error.
522 ** The Tcl interpreter will be created automatically if it has not been
523 ** already.
524 */
tclExpr_command(Th_Interp * interp,void * ctx,int argc,const char ** argv,int * argl)525 static int tclExpr_command(
526 Th_Interp *interp,
527 void *ctx,
528 int argc,
529 const char **argv,
530 int *argl
531 ){
532 Tcl_Interp *tclInterp;
533 Tcl_Obj *objPtr;
534 Tcl_Obj *resultObjPtr;
535 int rc = TH_OK;
536 int nResult;
537 const char *zResult;
538
539 if( createTclInterp(interp, ctx)!=TH_OK ){
540 return TH_ERROR;
541 }
542 if( argc<2 ){
543 return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
544 }
545 tclInterp = GET_CTX_TCL_INTERP(ctx);
546 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
547 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
548 return TH_ERROR;
549 }
550 rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
551 if( rc!=TH_OK ){
552 return rc;
553 }
554 Tcl_Preserve((ClientData)tclInterp);
555 if( argc==2 ){
556 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
557 Tcl_IncrRefCount(objPtr);
558 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
559 Tcl_DecrRefCount(objPtr); objPtr = 0;
560 }else{
561 USE_ARGV_TO_OBJV();
562 COPY_ARGV_TO_OBJV();
563 objPtr = Tcl_ConcatObj(objc, objv);
564 Tcl_IncrRefCount(objPtr);
565 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
566 Tcl_DecrRefCount(objPtr); objPtr = 0;
567 FREE_ARGV_TO_OBJV();
568 }
569 if( rc==TCL_OK ){
570 zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
571 }else{
572 zResult = getTclResult(tclInterp, &nResult);
573 }
574 Th_SetResult(interp, zResult, nResult);
575 if( rc==TCL_OK ){
576 Tcl_DecrRefCount(resultObjPtr); resultObjPtr = 0;
577 }
578 Tcl_Release((ClientData)tclInterp);
579 rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl,
580 getTh1ReturnCode(rc));
581 return rc;
582 }
583
584 /*
585 ** TH1 command: tclInvoke command ?arg ...?
586 **
587 ** Invokes the Tcl command using the supplied arguments. No additional
588 ** substitutions are performed on the arguments. The Tcl interpreter
589 ** will be created automatically if it has not been already.
590 */
tclInvoke_command(Th_Interp * interp,void * ctx,int argc,const char ** argv,int * argl)591 static int tclInvoke_command(
592 Th_Interp *interp,
593 void *ctx,
594 int argc,
595 const char **argv,
596 int *argl
597 ){
598 Tcl_Interp *tclInterp;
599 int rc = TH_OK;
600 int nResult;
601 const char *zResult;
602 USE_ARGV_TO_OBJV();
603
604 if( createTclInterp(interp, ctx)!=TH_OK ){
605 return TH_ERROR;
606 }
607 if( argc<2 ){
608 return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
609 }
610 tclInterp = GET_CTX_TCL_INTERP(ctx);
611 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
612 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
613 return TH_ERROR;
614 }
615 rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
616 if( rc!=TH_OK ){
617 return rc;
618 }
619 Tcl_Preserve((ClientData)tclInterp);
620 #if !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV
621 if( GET_CTX_TCL_USEOBJPROC(ctx) ){
622 Tcl_Command command;
623 Tcl_CmdInfo cmdInfo;
624 Tcl_Obj *objPtr = Tcl_NewStringObj(argv[1], argl[1]);
625 Tcl_IncrRefCount(objPtr);
626 command = Tcl_GetCommandFromObj(tclInterp, objPtr);
627 if( !command || Tcl_GetCommandInfoFromToken(command, &cmdInfo)==0 ){
628 Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
629 Tcl_DecrRefCount(objPtr); objPtr = 0;
630 Tcl_Release((ClientData)tclInterp);
631 return TH_ERROR;
632 }
633 if( !cmdInfo.objProc ){
634 Th_ErrorMessage(interp, "cannot invoke Tcl command:", argv[1], argl[1]);
635 Tcl_DecrRefCount(objPtr); objPtr = 0;
636 Tcl_Release((ClientData)tclInterp);
637 return TH_ERROR;
638 }
639 Tcl_DecrRefCount(objPtr); objPtr = 0;
640 COPY_ARGV_TO_OBJV();
641 Tcl_ResetResult(tclInterp);
642 rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
643 FREE_ARGV_TO_OBJV();
644 }else
645 #endif /* !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV */
646 {
647 COPY_ARGV_TO_OBJV();
648 rc = Tcl_EvalObjv(tclInterp, objc, objv, 0);
649 FREE_ARGV_TO_OBJV();
650 }
651 zResult = getTclResult(tclInterp, &nResult);
652 Th_SetResult(interp, zResult, nResult);
653 Tcl_Release((ClientData)tclInterp);
654 rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl,
655 getTh1ReturnCode(rc));
656 return rc;
657 }
658
659 /*
660 ** TH1 command: tclIsSafe
661 **
662 ** Returns non-zero if the Tcl interpreter is "safe". The Tcl interpreter
663 ** will be created automatically if it has not been already.
664 */
tclIsSafe_command(Th_Interp * interp,void * ctx,int argc,const char ** argv,int * argl)665 static int tclIsSafe_command(
666 Th_Interp *interp,
667 void *ctx,
668 int argc,
669 const char **argv,
670 int *argl
671 ){
672 Tcl_Interp *tclInterp;
673
674 if( createTclInterp(interp, ctx)!=TH_OK ){
675 return TH_ERROR;
676 }
677 if( argc!=1 ){
678 return Th_WrongNumArgs(interp, "tclIsSafe");
679 }
680 tclInterp = GET_CTX_TCL_INTERP(ctx);
681 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
682 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
683 return TH_ERROR;
684 }
685 Th_SetResultInt(interp, Tcl_IsSafe(tclInterp));
686 return TH_OK;
687 }
688
689 /*
690 ** TH1 command: tclMakeSafe
691 **
692 ** Forces the Tcl interpreter into "safe" mode by removing all "unsafe"
693 ** commands and variables. This operation cannot be undone. The Tcl
694 ** interpreter will remain "safe" until the process terminates.
695 */
tclMakeSafe_command(Th_Interp * interp,void * ctx,int argc,const char ** argv,int * argl)696 static int tclMakeSafe_command(
697 Th_Interp *interp,
698 void *ctx,
699 int argc,
700 const char **argv,
701 int *argl
702 ){
703 static int registerChans = 1;
704 Tcl_Interp *tclInterp;
705 int rc = TH_OK;
706
707 if( createTclInterp(interp, ctx)!=TH_OK ){
708 return TH_ERROR;
709 }
710 if( argc!=1 ){
711 return Th_WrongNumArgs(interp, "tclMakeSafe");
712 }
713 tclInterp = GET_CTX_TCL_INTERP(ctx);
714 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
715 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
716 return TH_ERROR;
717 }
718 if( Tcl_IsSafe(tclInterp) ){
719 Th_ErrorMessage(interp,
720 "Tcl interpreter is already 'safe'", (const char *)"", 0);
721 return TH_ERROR;
722 }
723 if( registerChans ){
724 /*
725 ** HACK: Prevent the call to Tcl_MakeSafe() from actually closing the
726 ** standard channels instead of simply unregistering them from
727 ** the Tcl interpreter. This should only need to be done once
728 ** per thread (process?).
729 */
730 registerChans = 0;
731 Tcl_RegisterChannel(NULL, Tcl_GetStdChannel(TCL_STDIN));
732 Tcl_RegisterChannel(NULL, Tcl_GetStdChannel(TCL_STDOUT));
733 Tcl_RegisterChannel(NULL, Tcl_GetStdChannel(TCL_STDERR));
734 }
735 Tcl_Preserve((ClientData)tclInterp);
736 if( Tcl_MakeSafe(tclInterp)!=TCL_OK ){
737 int nResult;
738 const char *zResult = getTclResult(tclInterp, &nResult);
739 Th_ErrorMessage(interp,
740 "could not make Tcl interpreter 'safe':", zResult, nResult);
741 rc = TH_ERROR;
742 }else{
743 Th_SetResult(interp, 0, 0);
744 }
745 Tcl_Release((ClientData)tclInterp);
746 return rc;
747 }
748
749 /*
750 ** Tcl command: th1Eval arg
751 **
752 ** Evaluates the TH1 script and returns its result verbatim. If a TH1 script
753 ** error is generated, it will be transformed into a Tcl script error.
754 */
Th1EvalObjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])755 static int Th1EvalObjCmd(
756 ClientData clientData,
757 Tcl_Interp *interp,
758 int objc,
759 Tcl_Obj *const objv[]
760 ){
761 Th_Interp *th1Interp;
762 int nArg;
763 const char *arg;
764 int rc;
765
766 if( objc!=2 ){
767 Tcl_WrongNumArgs(interp, 1, objv, "arg");
768 return TCL_ERROR;
769 }
770 th1Interp = (Th_Interp *)clientData;
771 if( !th1Interp ){
772 Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
773 return TCL_ERROR;
774 }
775 arg = Tcl_GetStringFromObj(objv[1], &nArg);
776 rc = Th_Eval(th1Interp, 0, arg, nArg);
777 arg = Th_GetResult(th1Interp, &nArg);
778 Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
779 return getTclReturnCode(rc);
780 }
781
782 /*
783 ** Tcl command: th1Expr arg
784 **
785 ** Evaluates the TH1 expression and returns its result verbatim. If a TH1
786 ** script error is generated, it will be transformed into a Tcl script error.
787 */
Th1ExprObjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])788 static int Th1ExprObjCmd(
789 ClientData clientData,
790 Tcl_Interp *interp,
791 int objc,
792 Tcl_Obj *const objv[]
793 ){
794 Th_Interp *th1Interp;
795 int nArg;
796 const char *arg;
797 int rc;
798
799 if( objc!=2 ){
800 Tcl_WrongNumArgs(interp, 1, objv, "arg");
801 return TCL_ERROR;
802 }
803 th1Interp = (Th_Interp *)clientData;
804 if( !th1Interp ){
805 Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
806 return TCL_ERROR;
807 }
808 arg = Tcl_GetStringFromObj(objv[1], &nArg);
809 rc = Th_Expr(th1Interp, arg, nArg);
810 arg = Th_GetResult(th1Interp, &nArg);
811 Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
812 return getTclReturnCode(rc);
813 }
814
815 /*
816 ** Array of Tcl integration commands. Used when adding or removing the Tcl
817 ** integration commands from TH1.
818 */
819 static struct _Command {
820 const char *zName;
821 Th_CommandProc xProc;
822 void *pContext;
823 } aCommand[] = {
824 {"tclEval", tclEval_command, 0},
825 {"tclExpr", tclExpr_command, 0},
826 {"tclInvoke", tclInvoke_command, 0},
827 {"tclIsSafe", tclIsSafe_command, 0},
828 {"tclMakeSafe", tclMakeSafe_command, 0},
829 {0, 0, 0}
830 };
831
832 /*
833 ** Called if the Tcl interpreter is deleted. Removes the Tcl integration
834 ** commands from the TH1 interpreter.
835 */
Th1DeleteProc(ClientData clientData,Tcl_Interp * interp)836 static void Th1DeleteProc(
837 ClientData clientData,
838 Tcl_Interp *interp
839 ){
840 int i;
841 Th_Interp *th1Interp = (Th_Interp *)clientData;
842
843 if( !th1Interp ) return;
844 /* Remove the Tcl integration commands. */
845 for(i=0; i<count(aCommand); i++){
846 Th_RenameCommand(th1Interp, aCommand[i].zName, -1, NULL, 0);
847 }
848 }
849
850 /*
851 ** When Tcl stubs support is enabled, attempts to dynamically load the Tcl
852 ** shared library and fetch the function pointers necessary to create an
853 ** interpreter and initialize the stubs mechanism; otherwise, simply setup
854 ** the function pointers provided by the caller with the statically linked
855 ** functions.
856 */
857 char *fossil_getenv(const char *zName); /* file.h */
858 int file_isdir(const char *zPath, int); /* file.h */
859 #define ExtFILE 0 /* file.h */
860 #define RepoFILE 1 /* file.h */
861 #define SymFILE 2 /* file.h */
862 char *file_dirname(const char *zPath); /* file.h */
863 void fossil_free(void *p); /* util.h */
864
loadTcl(Th_Interp * interp,void ** phLibrary,tcl_FindExecutableProc ** pxFindExecutable,tcl_CreateInterpProc ** pxCreateInterp,tcl_DeleteInterpProc ** pxDeleteInterp,tcl_FinalizeProc ** pxFinalize)865 static int loadTcl(
866 Th_Interp *interp,
867 void **phLibrary,
868 tcl_FindExecutableProc **pxFindExecutable,
869 tcl_CreateInterpProc **pxCreateInterp,
870 tcl_DeleteInterpProc **pxDeleteInterp,
871 tcl_FinalizeProc **pxFinalize
872 ){
873 #if defined(USE_TCL_STUBS)
874 const char *zEnvPath = fossil_getenv(TCL_PATH_ENV_VAR_NAME);
875 char aFileName[] = TCL_LIBRARY_NAME;
876 #endif /* defined(USE_TCL_STUBS) */
877
878 if( !phLibrary || !pxFindExecutable || !pxCreateInterp ||
879 !pxDeleteInterp || !pxFinalize ){
880 Th_ErrorMessage(interp,
881 "invalid Tcl loader argument(s)", (const char *)"", 0);
882 return TH_ERROR;
883 }
884 #if defined(USE_TCL_STUBS)
885 do {
886 char *zFileName;
887 void *hLibrary;
888 if( !zEnvPath ){
889 zFileName = aFileName; /* NOTE: Assume present in PATH. */
890 }else if( file_isdir(zEnvPath, ExtFILE)==1 ){
891 #if TCL_USE_SET_DLL_DIRECTORY
892 SetDllDirectory(zEnvPath); /* NOTE: Maybe needed for "zlib1.dll". */
893 #endif /* TCL_USE_SET_DLL_DIRECTORY */
894 /* NOTE: The environment variable contains a directory name. */
895 zFileName = sqlite3_mprintf("%s%c%s%c", zEnvPath, TCL_DIRECTORY_SEP,
896 aFileName, '\0');
897 }else{
898 #if TCL_USE_SET_DLL_DIRECTORY
899 char *zDirName = file_dirname(zEnvPath);
900 if( zDirName ){
901 SetDllDirectory(zDirName); /* NOTE: Maybe needed for "zlib1.dll". */
902 }
903 #endif /* TCL_USE_SET_DLL_DIRECTORY */
904 /* NOTE: The environment variable might contain a file name. */
905 zFileName = sqlite3_mprintf("%s%c", zEnvPath, '\0');
906 #if TCL_USE_SET_DLL_DIRECTORY
907 if( zDirName ){
908 fossil_free(zDirName); zDirName = 0;
909 }
910 #endif /* TCL_USE_SET_DLL_DIRECTORY */
911 }
912 if( !zFileName ) break;
913 hLibrary = dlopen(zFileName, RTLD_NOW | RTLD_GLOBAL);
914 /* NOTE: If the file name was allocated, free it now. */
915 if( zFileName!=aFileName ){
916 sqlite3_free(zFileName); zFileName = 0;
917 }
918 if( hLibrary ){
919 tcl_FindExecutableProc *xFindExecutable;
920 tcl_CreateInterpProc *xCreateInterp;
921 tcl_DeleteInterpProc *xDeleteInterp;
922 tcl_FinalizeProc *xFinalize;
923 const char *procName = TCL_FINDEXECUTABLE_NAME;
924 xFindExecutable = (tcl_FindExecutableProc *)dlsym(hLibrary, procName+1);
925 if( !xFindExecutable ){
926 xFindExecutable = (tcl_FindExecutableProc *)dlsym(hLibrary, procName);
927 }
928 if( !xFindExecutable ){
929 Th_ErrorMessage(interp,
930 "could not locate Tcl_FindExecutable", (const char *)"", 0);
931 dlclose(hLibrary); hLibrary = 0;
932 return TH_ERROR;
933 }
934 procName = TCL_CREATEINTERP_NAME;
935 xCreateInterp = (tcl_CreateInterpProc *)dlsym(hLibrary, procName+1);
936 if( !xCreateInterp ){
937 xCreateInterp = (tcl_CreateInterpProc *)dlsym(hLibrary, procName);
938 }
939 if( !xCreateInterp ){
940 Th_ErrorMessage(interp,
941 "could not locate Tcl_CreateInterp", (const char *)"", 0);
942 dlclose(hLibrary); hLibrary = 0;
943 return TH_ERROR;
944 }
945 procName = TCL_DELETEINTERP_NAME;
946 xDeleteInterp = (tcl_DeleteInterpProc *)dlsym(hLibrary, procName+1);
947 if( !xDeleteInterp ){
948 xDeleteInterp = (tcl_DeleteInterpProc *)dlsym(hLibrary, procName);
949 }
950 if( !xDeleteInterp ){
951 Th_ErrorMessage(interp,
952 "could not locate Tcl_DeleteInterp", (const char *)"", 0);
953 dlclose(hLibrary); hLibrary = 0;
954 return TH_ERROR;
955 }
956 procName = TCL_FINALIZE_NAME;
957 xFinalize = (tcl_FinalizeProc *)dlsym(hLibrary, procName+1);
958 if( !xFinalize ){
959 xFinalize = (tcl_FinalizeProc *)dlsym(hLibrary, procName);
960 }
961 if( !xFinalize ){
962 Th_ErrorMessage(interp,
963 "could not locate Tcl_Finalize", (const char *)"", 0);
964 dlclose(hLibrary); hLibrary = 0;
965 return TH_ERROR;
966 }
967 *phLibrary = hLibrary;
968 *pxFindExecutable = xFindExecutable;
969 *pxCreateInterp = xCreateInterp;
970 *pxDeleteInterp = xDeleteInterp;
971 *pxFinalize = xFinalize;
972 return TH_OK;
973 }
974 } while( --aFileName[TCL_MINOR_OFFSET]>'3' ); /* Tcl 8.4+ */
975 aFileName[TCL_MINOR_OFFSET] = 'x';
976 Th_ErrorMessage(interp,
977 "could not load any supported Tcl 8.x shared library \"",
978 aFileName, -1);
979 return TH_ERROR;
980 #else
981 *phLibrary = 0;
982 *pxFindExecutable = Tcl_FindExecutable;
983 *pxCreateInterp = Tcl_CreateInterp;
984 *pxDeleteInterp = Tcl_DeleteInterp;
985 *pxFinalize = Tcl_Finalize;
986 return TH_OK;
987 #endif /* defined(USE_TCL_STUBS) */
988 }
989
990 /*
991 ** Sets the "argv0", "argc", and "argv" script variables in the Tcl interpreter
992 ** based on the supplied command line arguments.
993 */
setTclArguments(Tcl_Interp * pInterp,int argc,char ** argv)994 static int setTclArguments(
995 Tcl_Interp *pInterp,
996 int argc,
997 char **argv
998 ){
999 Tcl_Obj *objPtr;
1000 Tcl_Obj *resultObjPtr;
1001 Tcl_Obj *listPtr;
1002 int rc = TCL_OK;
1003
1004 if( argc<=0 || !argv ){
1005 return TCL_OK;
1006 }
1007 objPtr = Tcl_NewStringObj(argv[0], -1);
1008 Tcl_IncrRefCount(objPtr);
1009 resultObjPtr = Tcl_SetVar2Ex(pInterp, "argv0", NULL, objPtr,
1010 TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
1011 Tcl_DecrRefCount(objPtr); objPtr = 0;
1012 if( !resultObjPtr ){
1013 return TCL_ERROR;
1014 }
1015 objPtr = Tcl_NewWideIntObj(argc - 1);
1016 Tcl_IncrRefCount(objPtr);
1017 resultObjPtr = Tcl_SetVar2Ex(pInterp, "argc", NULL, objPtr,
1018 TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
1019 Tcl_DecrRefCount(objPtr); objPtr = 0;
1020 if( !resultObjPtr ){
1021 return TCL_ERROR;
1022 }
1023 listPtr = Tcl_NewListObj(0, NULL);
1024 Tcl_IncrRefCount(listPtr);
1025 if( argc>1 ){
1026 while( --argc ){
1027 objPtr = Tcl_NewStringObj(*++argv, -1);
1028 Tcl_IncrRefCount(objPtr);
1029 rc = Tcl_ListObjAppendElement(pInterp, listPtr, objPtr);
1030 Tcl_DecrRefCount(objPtr); objPtr = 0;
1031 if( rc!=TCL_OK ){
1032 break;
1033 }
1034 }
1035 }
1036 if( rc==TCL_OK ){
1037 resultObjPtr = Tcl_SetVar2Ex(pInterp, "argv", NULL, listPtr,
1038 TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
1039 if( !resultObjPtr ){
1040 rc = TCL_ERROR;
1041 }
1042 }
1043 Tcl_DecrRefCount(listPtr); listPtr = 0;
1044 return rc;
1045 }
1046
1047 /*
1048 ** Evaluate a Tcl script, creating the Tcl interpreter if necessary. If the
1049 ** Tcl script succeeds, start a Tcl event loop until there are no more events
1050 ** remaining to process -OR- the script calls [exit]. If the bWait argument
1051 ** is zero, only process events that are already in the queue; otherwise,
1052 ** process events until the script terminates the Tcl event loop.
1053 */
1054 void fossil_print(const char *zFormat, ...); /* printf.h */
1055
evaluateTclWithEvents(Th_Interp * interp,void * pContext,const char * zScript,int nScript,int bCancel,int bWait,int bVerbose)1056 int evaluateTclWithEvents(
1057 Th_Interp *interp,
1058 void *pContext,
1059 const char *zScript,
1060 int nScript,
1061 int bCancel,
1062 int bWait,
1063 int bVerbose
1064 ){
1065 struct TclContext *tclContext = (struct TclContext *)pContext;
1066 Tcl_Interp *tclInterp;
1067 int rc;
1068 int flags = TCL_ALL_EVENTS;
1069 int useTip285;
1070
1071 if( createTclInterp(interp, pContext)!=TH_OK ){
1072 return TH_ERROR;
1073 }
1074 tclInterp = tclContext->interp;
1075 useTip285 = bCancel ? tclContext->useTip285 : 0;
1076 rc = Tcl_EvalEx(tclInterp, zScript, nScript, TCL_EVAL_GLOBAL);
1077 if( rc!=TCL_OK ){
1078 if( bVerbose ){
1079 const char *zResult = getTclResult(tclInterp, 0);
1080 fossil_print("%s: ", getTclReturnCodeName(rc, 0));
1081 fossil_print("%s\n", zResult);
1082 }
1083 return rc;
1084 }
1085 if( !bWait ) flags |= TCL_DONT_WAIT;
1086 Tcl_Preserve((ClientData)tclInterp);
1087 while( Tcl_DoOneEvent(flags) ){
1088 if( Tcl_InterpDeleted(tclInterp) ){
1089 break;
1090 }
1091 #if MINIMUM_TCL_VERSION(8, 6)
1092 if( useTip285 && Tcl_Canceled(tclInterp, 0)!=TCL_OK ){
1093 break;
1094 }
1095 #endif
1096 }
1097 Tcl_Release((ClientData)tclInterp);
1098 return rc;
1099 }
1100
1101 /*
1102 ** Creates and initializes a Tcl interpreter for use with the specified TH1
1103 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
1104 ** by the caller.
1105 */
createTclInterp(Th_Interp * interp,void * pContext)1106 static int createTclInterp(
1107 Th_Interp *interp,
1108 void *pContext
1109 ){
1110 struct TclContext *tclContext = (struct TclContext *)pContext;
1111 int argc;
1112 char **argv;
1113 char *argv0 = 0;
1114 Tcl_Interp *tclInterp;
1115 const char *setup;
1116
1117 if( !tclContext ){
1118 Th_ErrorMessage(interp,
1119 "invalid Tcl context", (const char *)"", 0);
1120 return TH_ERROR;
1121 }
1122 if( tclContext->interp ){
1123 return TH_OK;
1124 }
1125 if( loadTcl(interp, &tclContext->hLibrary, &tclContext->xFindExecutable,
1126 &tclContext->xCreateInterp, &tclContext->xDeleteInterp,
1127 &tclContext->xFinalize)!=TH_OK ){
1128 return TH_ERROR;
1129 }
1130 argc = tclContext->argc;
1131 argv = tclContext->argv;
1132 if( argc>0 && argv ){
1133 argv0 = argv[0];
1134 }
1135 tclContext->xFindExecutable(argv0);
1136 tclInterp = tclContext->xCreateInterp();
1137 if( !tclInterp ){
1138 Th_ErrorMessage(interp,
1139 "could not create Tcl interpreter", (const char *)"", 0);
1140 return TH_ERROR;
1141 }
1142 #if defined(USE_TCL_STUBS)
1143 #if defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS)
1144 if( initTclStubs(interp, tclInterp)!=TH_OK ){
1145 tclContext->xDeleteInterp(tclInterp);
1146 tclInterp = 0;
1147 return TH_ERROR;
1148 }
1149 #else
1150 if( !Tcl_InitStubs(tclInterp, "8.4", 0) ){
1151 Th_ErrorMessage(interp,
1152 "could not initialize Tcl stubs", (const char *)"", 0);
1153 tclContext->xDeleteInterp(tclInterp);
1154 tclInterp = 0;
1155 return TH_ERROR;
1156 }
1157 #endif /* defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS) */
1158 #endif /* defined(USE_TCL_STUBS) */
1159 if( Tcl_InterpDeleted(tclInterp) ){
1160 Th_ErrorMessage(interp,
1161 "Tcl interpreter appears to be deleted", (const char *)"", 0);
1162 Tcl_DeleteInterp(tclInterp); /* TODO: Redundant? */
1163 tclInterp = 0;
1164 return TH_ERROR;
1165 }
1166 tclContext->interp = tclInterp;
1167 if( Tcl_Init(tclInterp)!=TCL_OK ){
1168 Th_ErrorMessage(interp,
1169 "Tcl initialization error:", Tcl_GetString(Tcl_GetObjResult(tclInterp)), -1);
1170 Tcl_DeleteInterp(tclInterp);
1171 tclContext->interp = tclInterp = 0;
1172 return TH_ERROR;
1173 }
1174 if( setTclArguments(tclInterp, argc, argv)!=TCL_OK ){
1175 Th_ErrorMessage(interp,
1176 "Tcl error setting arguments:", Tcl_GetString(Tcl_GetObjResult(tclInterp)), -1);
1177 Tcl_DeleteInterp(tclInterp);
1178 tclContext->interp = tclInterp = 0;
1179 return TH_ERROR;
1180 }
1181 /*
1182 ** Determine (and cache) if an objProc can be called directly for a Tcl
1183 ** command invoked via the tclInvoke TH1 command.
1184 */
1185 tclContext->useObjProc = canUseObjProc();
1186 /*
1187 ** Determine (and cache) whether or not we can use TIP #285 (asynchronous
1188 ** script cancellation).
1189 */
1190 tclContext->useTip285 = canUseTip285();
1191 /* Add the TH1 integration commands to Tcl. */
1192 Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
1193 Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
1194 Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
1195 /* If necessary, evaluate the custom Tcl setup script. */
1196 setup = tclContext->setup;
1197 if( setup && Tcl_EvalEx(tclInterp, setup, -1, 0)!=TCL_OK ){
1198 Th_ErrorMessage(interp,
1199 "Tcl setup script error:", Tcl_GetString(Tcl_GetObjResult(tclInterp)), -1);
1200 Tcl_DeleteInterp(tclInterp);
1201 tclContext->interp = tclInterp = 0;
1202 return TH_ERROR;
1203 }
1204 return TH_OK;
1205 }
1206
1207 /*
1208 ** Finalizes and unloads the previously loaded Tcl library, if applicable.
1209 */
unloadTcl(Th_Interp * interp,void * pContext)1210 int unloadTcl(
1211 Th_Interp *interp,
1212 void *pContext
1213 ){
1214 struct TclContext *tclContext = (struct TclContext *)pContext;
1215 Tcl_Interp *tclInterp;
1216 tcl_FinalizeProc *xFinalize;
1217 #if defined(USE_TCL_STUBS)
1218 void *hLibrary;
1219 #endif /* defined(USE_TCL_STUBS) */
1220
1221 if( !tclContext ){
1222 Th_ErrorMessage(interp,
1223 "invalid Tcl context", (const char *)"", 0);
1224 return TH_ERROR;
1225 }
1226 /*
1227 ** Grab the Tcl_Finalize function pointer prior to deleting the Tcl
1228 ** interpreter because the memory backing the Tcl stubs table will
1229 ** be going away.
1230 */
1231 xFinalize = tclContext->xFinalize;
1232 /*
1233 ** If the Tcl interpreter has been created, formally delete it now.
1234 */
1235 tclInterp = tclContext->interp;
1236 if( tclInterp ){
1237 Tcl_DeleteInterp(tclInterp);
1238 tclContext->interp = tclInterp = 0;
1239 }
1240 /*
1241 ** If the Tcl library is not finalized prior to unloading it, a deadlock
1242 ** can occur in some circumstances (i.e. the [clock] thread is running).
1243 */
1244 if( xFinalize ) xFinalize();
1245 #if defined(USE_TCL_STUBS)
1246 /*
1247 ** If Tcl is compiled on Windows using the latest MinGW, Fossil can crash
1248 ** when exiting while a stubs-enabled Tcl is still loaded. This is due to
1249 ** a bug in MinGW, see:
1250 **
1251 ** http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724
1252 **
1253 ** The workaround is to manually unload the loaded Tcl library prior to
1254 ** exiting the process.
1255 */
1256 hLibrary = tclContext->hLibrary;
1257 if( hLibrary ){
1258 dlclose(hLibrary);
1259 tclContext->hLibrary = hLibrary = 0;
1260 }
1261 #endif /* defined(USE_TCL_STUBS) */
1262 return TH_OK;
1263 }
1264
1265 /*
1266 ** Register the Tcl language commands with interpreter interp.
1267 ** Usually this is called soon after interpreter creation.
1268 */
th_register_tcl(Th_Interp * interp,void * pContext)1269 int th_register_tcl(
1270 Th_Interp *interp,
1271 void *pContext
1272 ){
1273 int i;
1274
1275 /* Add the Tcl integration commands to TH1. */
1276 for(i=0; i<count(aCommand); i++){
1277 void *ctx;
1278 if( !aCommand[i].zName || !aCommand[i].xProc ) continue;
1279 ctx = aCommand[i].pContext;
1280 /* Use Tcl interpreter for context? */
1281 if( !ctx ) ctx = pContext;
1282 Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
1283 }
1284 return TH_OK;
1285 }
1286
1287 #endif /* FOSSIL_ENABLE_TCL */
1288