Fossil SCM

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

Keyboard Shortcuts

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