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