Fossil SCM

Add formal unloading support to the Tcl integration subsystem. This is necessary to prevent a deadlock while exiting the process when Tcl is loaded. Add runtime detection of the ability to directly invoke an objProc for a Tcl command. Support USE_TCL_STUBS define in the version information.

mistachkin 2013-09-25 23:56 trunk

Commit 6b58c67ed8f95c327eab7e97e1977bcb23ef0138

Parent da96f916cb02bdb…

7 files changed +18 -10 +4 +6 +174 -85 +2 -1 +1 -1 +5

~ src/main.c ~ src/th.h ~ src/th_main.c ~ src/th_tcl.c ~ test/th1-tcl.test ~ test/th1-tcl8.txt ~ win/fossil.rc

M src/main.c

+18 -10

		--- src/main.c
		+++ src/main.c
		@@ -100,11 +100,13 @@
100	100	char *argv; / Full copy of the original (expanded) arguments. */
101	101	void library; / The Tcl library module handle. */
102	102	void xFindExecutable; / See tcl_FindExecutableProc in th_tcl.c. */
103	103	void xCreateInterp; / See tcl_CreateInterpProc in th_tcl.c. */
104	104	void xDeleteInterp; / See tcl_DeleteInterpProc in th_tcl.c. */
	105	+ void xFinalize; / See tcl_FinalizeProc in th_tcl.c. */
105	106	Tcl_Interp interp; / The on-demand created Tcl interpreter. */
	107	+ int useObjProc; /* Non-zero if an objProc can be called directly. */
106	108	char setup; / The optional Tcl setup script. */
107	109	void xPreEval; / Optional, called before Tcl_Eval(). /
108	110	void pPreContext; / Optional, provided to xPreEval(). */
109	111	void xPostEval; / Optional, called after Tcl_Eval(). /
110	112	void pPostContext; / Optional, provided to xPostEval(). */
		@@ -344,19 +346,22 @@
344	346	/*
345	347	** atexit() handler which frees up "some" of the resources
346	348	** used by fossil.
347	349	*/
348	350	static void fossil_atexit(void) {
349		-#if defined(_WIN32) && defined(USE_TCL_STUBS)
350		- /* If Tcl is compiled on win32 using the latest mingw,
351		- * fossil crashes when exiting while Tcl is still loaded.
352		- * That's a bug in mingw, see:
353		- * <http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724>
354		- * but the workaround is not that bad at all: */
355		- if( g.tcl.library ){
356		- FreeLibrary(g.tcl.library);
357		- }
	351	+#if defined(_WIN32) && defined(FOSSIL_ENABLE_TCL) && defined(USE_TCL_STUBS)
	352	+ /*
	353	+ ** If Tcl is compiled on Windows using the latest MinGW, Fossil can crash
	354	+ ** when exiting while a stubs-enabled Tcl is still loaded. This is due to
	355	+ ** a bug in MinGW, see:
	356	+ **
	357	+ ** http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724
	358	+ **
	359	+ ** The workaround is to manually unload the loaded Tcl library prior to
	360	+ ** exiting the process.
	361	+ */
	362	+ unloadTcl(g.interp, &g.tcl);
358	363	#endif
359	364	#ifdef FOSSIL_ENABLE_JSON
360	365	cson_value_free(g.json.gc.v);
361	366	memset(&g.json, 0, sizeof(g.json));
362	367	#endif
		@@ -823,16 +828,19 @@
823	828	#if defined(FOSSIL_ENABLE_SSL)
824	829	fossil_print("SSL (%s)\n", OPENSSL_VERSION_TEXT);
825	830	#endif
826	831	#if defined(FOSSIL_ENABLE_TCL)
827	832	Th_FossilInit(TH_INIT_DEFAULT \| TH_INIT_FORCE_TCL);
828		- rc = Th_Eval(g.interp, 0, "tclEval {info patchlevel}", -1);
	833	+ rc = Th_Eval(g.interp, 0, "tclInvoke info patchlevel", -1);
829	834	zRc = Th_ReturnCodeName(rc, 0);
830	835	fossil_print("TCL (Tcl %s, loaded %s: %s)\n",
831	836	TCL_PATCH_LEVEL, zRc, Th_GetResult(g.interp, 0)
832	837	);
833	838	#endif
	839	+#if defined(USE_TCL_STUBS)
	840	+ fossil_print("USE_TCL_STUBS\n");
	841	+#endif
834	842	#if defined(FOSSIL_ENABLE_TCL_STUBS)
835	843	fossil_print("TCL_STUBS\n");
836	844	#endif
837	845	#if defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS)
838	846	fossil_print("TCL_PRIVATE_STUBS\n");
839	847

	--- src/main.c
	+++ src/main.c
	@@ -100,11 +100,13 @@
100	char *argv; / Full copy of the original (expanded) arguments. */
101	void library; / The Tcl library module handle. */
102	void xFindExecutable; / See tcl_FindExecutableProc in th_tcl.c. */
103	void xCreateInterp; / See tcl_CreateInterpProc in th_tcl.c. */
104	void xDeleteInterp; / See tcl_DeleteInterpProc in th_tcl.c. */

105	Tcl_Interp interp; / The on-demand created Tcl interpreter. */

106	char setup; / The optional Tcl setup script. */
107	void xPreEval; / Optional, called before Tcl_Eval(). /
108	void pPreContext; / Optional, provided to xPreEval(). */
109	void xPostEval; / Optional, called after Tcl_Eval(). /
110	void pPostContext; / Optional, provided to xPostEval(). */
	@@ -344,19 +346,22 @@
344	/*
345	** atexit() handler which frees up "some" of the resources
346	** used by fossil.
347	*/
348	static void fossil_atexit(void) {
349	#if defined(_WIN32) && defined(USE_TCL_STUBS)
350	/* If Tcl is compiled on win32 using the latest mingw,
351	* fossil crashes when exiting while Tcl is still loaded.
352	* That's a bug in mingw, see:
353	* <http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724>
354	* but the workaround is not that bad at all: */
355	if( g.tcl.library ){
356	FreeLibrary(g.tcl.library);
357	}



358	#endif
359	#ifdef FOSSIL_ENABLE_JSON
360	cson_value_free(g.json.gc.v);
361	memset(&g.json, 0, sizeof(g.json));
362	#endif
	@@ -823,16 +828,19 @@
823	#if defined(FOSSIL_ENABLE_SSL)
824	fossil_print("SSL (%s)\n", OPENSSL_VERSION_TEXT);
825	#endif
826	#if defined(FOSSIL_ENABLE_TCL)
827	Th_FossilInit(TH_INIT_DEFAULT \| TH_INIT_FORCE_TCL);
828	rc = Th_Eval(g.interp, 0, "tclEval {info patchlevel}", -1);
829	zRc = Th_ReturnCodeName(rc, 0);
830	fossil_print("TCL (Tcl %s, loaded %s: %s)\n",
831	TCL_PATCH_LEVEL, zRc, Th_GetResult(g.interp, 0)
832	);
833	#endif



834	#if defined(FOSSIL_ENABLE_TCL_STUBS)
835	fossil_print("TCL_STUBS\n");
836	#endif
837	#if defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS)
838	fossil_print("TCL_PRIVATE_STUBS\n");
839

	--- src/main.c
	+++ src/main.c
	@@ -100,11 +100,13 @@
100	char *argv; / Full copy of the original (expanded) arguments. */
101	void library; / The Tcl library module handle. */
102	void xFindExecutable; / See tcl_FindExecutableProc in th_tcl.c. */
103	void xCreateInterp; / See tcl_CreateInterpProc in th_tcl.c. */
104	void xDeleteInterp; / See tcl_DeleteInterpProc in th_tcl.c. */
105	void xFinalize; / See tcl_FinalizeProc in th_tcl.c. */
106	Tcl_Interp interp; / The on-demand created Tcl interpreter. */
107	int useObjProc; /* Non-zero if an objProc can be called directly. */
108	char setup; / The optional Tcl setup script. */
109	void xPreEval; / Optional, called before Tcl_Eval(). /
110	void pPreContext; / Optional, provided to xPreEval(). */
111	void xPostEval; / Optional, called after Tcl_Eval(). /
112	void pPostContext; / Optional, provided to xPostEval(). */
	@@ -344,19 +346,22 @@
346	/*
347	** atexit() handler which frees up "some" of the resources
348	** used by fossil.
349	*/
350	static void fossil_atexit(void) {
351	#if defined(_WIN32) && defined(FOSSIL_ENABLE_TCL) && defined(USE_TCL_STUBS)
352	/*
353	** If Tcl is compiled on Windows using the latest MinGW, Fossil can crash
354	** when exiting while a stubs-enabled Tcl is still loaded. This is due to
355	** a bug in MinGW, see:
356	**
357	** http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724
358	**
359	** The workaround is to manually unload the loaded Tcl library prior to
360	** exiting the process.
361	*/
362	unloadTcl(g.interp, &g.tcl);
363	#endif
364	#ifdef FOSSIL_ENABLE_JSON
365	cson_value_free(g.json.gc.v);
366	memset(&g.json, 0, sizeof(g.json));
367	#endif
	@@ -823,16 +828,19 @@
828	#if defined(FOSSIL_ENABLE_SSL)
829	fossil_print("SSL (%s)\n", OPENSSL_VERSION_TEXT);
830	#endif
831	#if defined(FOSSIL_ENABLE_TCL)
832	Th_FossilInit(TH_INIT_DEFAULT \| TH_INIT_FORCE_TCL);
833	rc = Th_Eval(g.interp, 0, "tclInvoke info patchlevel", -1);
834	zRc = Th_ReturnCodeName(rc, 0);
835	fossil_print("TCL (Tcl %s, loaded %s: %s)\n",
836	TCL_PATCH_LEVEL, zRc, Th_GetResult(g.interp, 0)
837	);
838	#endif
839	#if defined(USE_TCL_STUBS)
840	fossil_print("USE_TCL_STUBS\n");
841	#endif
842	#if defined(FOSSIL_ENABLE_TCL_STUBS)
843	fossil_print("TCL_STUBS\n");
844	#endif
845	#if defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS)
846	fossil_print("TCL_PRIVATE_STUBS\n");
847

M src/th.h

		--- src/th.h
		+++ src/th.h
		@@ -155,11 +155,15 @@
155	155	*/
156	156	int th_register_language(Th_Interp interp); / th_lang.c */
157	157	int th_register_sqlite(Th_Interp interp); / th_sqlite.c */
158	158	int th_register_vfs(Th_Interp interp); / th_vfs.c */
159	159	int th_register_testvfs(Th_Interp interp); / th_testvfs.c */
	160	+
	161	+#ifdef FOSSIL_ENABLE_TCL
160	162	int th_register_tcl(Th_Interp interp, void pContext); /* th_tcl.c */
	163	+int unloadTcl(Th_Interp interp, void pContext); /* th_tcl.c */
	164	+#endif
161	165
162	166	/*
163	167	** General purpose hash table from th_lang.c.
164	168	*/
165	169	typedef struct Th_Hash Th_Hash;
166	170

	--- src/th.h
	+++ src/th.h
	@@ -155,11 +155,15 @@
155	*/
156	int th_register_language(Th_Interp interp); / th_lang.c */
157	int th_register_sqlite(Th_Interp interp); / th_sqlite.c */
158	int th_register_vfs(Th_Interp interp); / th_vfs.c */
159	int th_register_testvfs(Th_Interp interp); / th_testvfs.c */


160	int th_register_tcl(Th_Interp interp, void pContext); /* th_tcl.c */


161
162	/*
163	** General purpose hash table from th_lang.c.
164	*/
165	typedef struct Th_Hash Th_Hash;
166

	--- src/th.h
	+++ src/th.h
	@@ -155,11 +155,15 @@
155	*/
156	int th_register_language(Th_Interp interp); / th_lang.c */
157	int th_register_sqlite(Th_Interp interp); / th_sqlite.c */
158	int th_register_vfs(Th_Interp interp); / th_vfs.c */
159	int th_register_testvfs(Th_Interp interp); / th_testvfs.c */
160
161	#ifdef FOSSIL_ENABLE_TCL
162	int th_register_tcl(Th_Interp interp, void pContext); /* th_tcl.c */
163	int unloadTcl(Th_Interp interp, void pContext); /* th_tcl.c */
164	#endif
165
166	/*
167	** General purpose hash table from th_lang.c.
168	*/
169	typedef struct Th_Hash Th_Hash;
170

M src/th_main.c

		--- src/th_main.c
		+++ src/th_main.c
		@@ -298,10 +298,11 @@
298	298	** Return true if the fossil binary has the given compile-time feature
299	299	** enabled. The set of features includes:
300	300	**
301	301	** "ssl" = FOSSIL_ENABLE_SSL
302	302	** "tcl" = FOSSIL_ENABLE_TCL
	303	+** "useTclStubs" = USE_TCL_STUBS
303	304	** "tclStubs" = FOSSIL_ENABLE_TCL_STUBS
304	305	** "tclPrivateStubs" = FOSSIL_ENABLE_TCL_PRIVATE_STUBS
305	306	** "json" = FOSSIL_ENABLE_JSON
306	307	** "markdown" = FOSSIL_ENABLE_MARKDOWN
307	308	**
		@@ -329,10 +330,15 @@
329	330	#endif
330	331	#if defined(FOSSIL_ENABLE_TCL)
331	332	else if( 0 == fossil_strnicmp( zArg, "tcl\0", 4 ) ){
332	333	rc = 1;
333	334	}
	335	+#endif
	336	+#if defined(USE_TCL_STUBS)
	337	+ else if( 0 == fossil_strnicmp( zArg, "useTclStubs\0", 12 ) ){
	338	+ rc = 1;
	339	+ }
334	340	#endif
335	341	#if defined(FOSSIL_ENABLE_TCL_STUBS)
336	342	else if( 0 == fossil_strnicmp( zArg, "tclStubs\0", 9 ) ){
337	343	rc = 1;
338	344	}
339	345

	--- src/th_main.c
	+++ src/th_main.c
	@@ -298,10 +298,11 @@
298	** Return true if the fossil binary has the given compile-time feature
299	** enabled. The set of features includes:
300	**
301	** "ssl" = FOSSIL_ENABLE_SSL
302	** "tcl" = FOSSIL_ENABLE_TCL

303	** "tclStubs" = FOSSIL_ENABLE_TCL_STUBS
304	** "tclPrivateStubs" = FOSSIL_ENABLE_TCL_PRIVATE_STUBS
305	** "json" = FOSSIL_ENABLE_JSON
306	** "markdown" = FOSSIL_ENABLE_MARKDOWN
307	**
	@@ -329,10 +330,15 @@
329	#endif
330	#if defined(FOSSIL_ENABLE_TCL)
331	else if( 0 == fossil_strnicmp( zArg, "tcl\0", 4 ) ){
332	rc = 1;
333	}





334	#endif
335	#if defined(FOSSIL_ENABLE_TCL_STUBS)
336	else if( 0 == fossil_strnicmp( zArg, "tclStubs\0", 9 ) ){
337	rc = 1;
338	}
339

	--- src/th_main.c
	+++ src/th_main.c
	@@ -298,10 +298,11 @@
298	** Return true if the fossil binary has the given compile-time feature
299	** enabled. The set of features includes:
300	**
301	** "ssl" = FOSSIL_ENABLE_SSL
302	** "tcl" = FOSSIL_ENABLE_TCL
303	** "useTclStubs" = USE_TCL_STUBS
304	** "tclStubs" = FOSSIL_ENABLE_TCL_STUBS
305	** "tclPrivateStubs" = FOSSIL_ENABLE_TCL_PRIVATE_STUBS
306	** "json" = FOSSIL_ENABLE_JSON
307	** "markdown" = FOSSIL_ENABLE_MARKDOWN
308	**
	@@ -329,10 +330,15 @@
330	#endif
331	#if defined(FOSSIL_ENABLE_TCL)
332	else if( 0 == fossil_strnicmp( zArg, "tcl\0", 4 ) ){
333	rc = 1;
334	}
335	#endif
336	#if defined(USE_TCL_STUBS)
337	else if( 0 == fossil_strnicmp( zArg, "useTclStubs\0", 12 ) ){
338	rc = 1;
339	}
340	#endif
341	#if defined(FOSSIL_ENABLE_TCL_STUBS)
342	else if( 0 == fossil_strnicmp( zArg, "tclStubs\0", 9 ) ){
343	rc = 1;
344	}
345

M src/th_tcl.c

+174 -85

		--- src/th_tcl.c
		+++ src/th_tcl.c
		@@ -23,48 +23,14 @@
23	23	#ifdef FOSSIL_ENABLE_TCL
24	24
25	25	#include "th.h"
26	26	#include "tcl.h"
27	27
28		-/*
29		-** Has the decision about whether or not to use Tcl_EvalObjv already been made
30		-** via the Makefile?
31		- */
32		-#if !defined(USE_TCL_EVALOBJV)
33		-/*
34		-** Are we being compiled against Tcl 8.6b1 or b2? This check is [mostly]
35		-** wrong for at the following reason:
36		-**
37		-** 1. Technically, this check is completely useless when the stubs mechanism
38		-** is in use. In that case, a runtime version check would be required and
39		-** that has not been implemented.
40		-**
41		-** However, if a particular user compiles and runs against Tcl 8.6b1 or b2,
42		-** this will cause a fallback to using the "conservative" method of directly
43		-** invoking a Tcl command. In that case, potential crashes will be avoided if
44		-** the user just so happened to compile or run against Tcl 8.6b1 or b2.
45		- */
46		-#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION == 6) && \
47		- (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE) && (TCL_RELEASE_SERIAL < 3)
48		-/*
49		-** Workaround NRE-specific issue in Tcl_EvalObjCmd (SF bug #3399564) by using
50		-** Tcl_EvalObjv instead of invoking the objProc directly.
51		- */
52		-# define USE_TCL_EVALOBJV (1)
53		-#else
54		-/*
55		-** We should be able to safely use Tcl_GetCommandInfoFromToken, when the need
56		-** arises, to invoke a specific Tcl command "directly" with some arguments.
57		- */
58		-# define USE_TCL_EVALOBJV (0)
59		-#endif /* (TCL_MAJOR_VERSION > 8) ... */
60		-#endif /* !defined(USE_TCL_EVALOBJV) */
61		-
62	28	/*
63	29	** These macros are designed to reduce the redundant code required to marshal
64	30	** arguments from TH1 to Tcl.
65		- */
	31	+*/
66	32	#define USE_ARGV_TO_OBJV() \
67	33	int objc; \
68	34	Tcl_Obj **objv; \
69	35	int i;
70	36
		@@ -83,18 +49,25 @@
83	49	ckfree((char *)objv);
84	50
85	51	/*
86	52	** Fetch the Tcl interpreter from the specified void pointer, cast to a Tcl
87	53	** context.
88		- */
	54	+*/
89	55	#define GET_CTX_TCL_INTERP(ctx) \
90	56	((struct TclContext *)(ctx))->interp
91	57
	58	+/*
	59	+** Fetch the (logically boolean) value from the specified void pointer that
	60	+** indicates whether or not we can/should use direct objProc calls.
	61	+*/
	62	+#define GET_CTX_TCL_USEOBJPROC(ctx) \
	63	+ ((struct TclContext *)(ctx))->useObjProc
	64	+
92	65	/*
93	66	** Define the Tcl shared library name, some exported function names, and some
94	67	** cross-platform macros for use with the Tcl stubs mechanism, when enabled.
95		- */
	68	+*/
96	69	#if defined(USE_TCL_STUBS)
97	70	# if defined(_WIN32)
98	71	# define WIN32_LEAN_AND_MEAN
99	72	# include <windows.h>
100	73	# ifndef TCL_LIBRARY_NAME
		@@ -144,33 +117,37 @@
144	117	# define TCL_CREATEINTERP_NAME "_Tcl_CreateInterp"
145	118	# endif
146	119	# ifndef TCL_DELETEINTERP_NAME
147	120	# define TCL_DELETEINTERP_NAME "_Tcl_DeleteInterp"
148	121	# endif
	122	+# ifndef TCL_FINALIZE_NAME
	123	+# define TCL_FINALIZE_NAME "_Tcl_Finalize"
	124	+# endif
149	125	#endif /* defined(USE_TCL_STUBS) */
150	126
151	127	/*
152	128	** The function types for Tcl_FindExecutable and Tcl_CreateInterp are needed
153	129	** when the Tcl library is being loaded dynamically by a stubs-enabled
154	130	** application (i.e. the inverse of using a stubs-enabled package). These are
155	131	** the only Tcl API functions that MUST be called prior to being able to call
156	132	** Tcl_InitStubs (i.e. because it requires a Tcl interpreter). For complete
157	133	** cleanup if the Tcl stubs initialization fails somehow, the Tcl_DeleteInterp
158		-** function type is also required.
159		- */
	134	+** and Tcl_Finalize function types are also required.
	135	+*/
160	136	typedef void (tcl_FindExecutableProc) (const char * argv0);
161	137	typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
162	138	typedef void (tcl_DeleteInterpProc) (Tcl_Interp *interp);
	139	+typedef void (tcl_FinalizeProc) (void);
163	140
164	141	/*
165	142	** The function types for the "hook" functions to be called before and after a
166	143	** TH1 command makes a call to evaluate a Tcl script. If the "pre" function
167	144	** returns anything but TH_OK, then evaluation of the Tcl script is skipped and
168	145	** that value is used as the return code. If the "post" function returns
169	146	** anything other than its rc argument, that will become the new return code
170	147	** for the command.
171		- */
	148	+*/
172	149	typedef int (tcl_NotifyProc) (
173	150	void pContext, / The context for this notification. */
174	151	Th_Interp interp, / The TH1 interpreter being used. */
175	152	void ctx, / The original TH1 command context. */
176	153	int argc, /* Number of arguments for the TH1 command. */
		@@ -181,27 +158,27 @@
181	158
182	159	/*
183	160	** Are we using our own private implementation of the Tcl stubs mechanism? If
184	161	** this is enabled, it prevents the user from having to link against the Tcl
185	162	** stubs library for the target platform, which may not be readily available.
186		- */
	163	+*/
187	164	#if defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS)
188	165	/*
189	166	** HACK: Using some preprocessor magic and a private static variable, redirect
190	167	** the Tcl API calls [found within this file] to the function pointers
191	168	** that will be contained in our private Tcl stubs table. This takes
192	169	** advantage of the fact that the Tcl headers always define the Tcl API
193	170	** functions in terms of the "tclStubsPtr" variable.
194		- */
	171	+*/
195	172	#define tclStubsPtr privateTclStubsPtr
196	173	static const TclStubs *tclStubsPtr = NULL;
197	174
198	175	/*
199	176	** Create a Tcl interpreter structure that mirrors just enough fields to get
200	177	** it up and running successfully with our private implementation of the Tcl
201	178	** stubs mechanism.
202		- */
	179	+*/
203	180	struct PrivateTclInterp {
204	181	char *result;
205	182	Tcl_FreeProc *freeProc;
206	183	int errorLine;
207	184	const struct TclStubs *stubTable;
		@@ -209,11 +186,11 @@
209	186
210	187	/*
211	188	** Fossil can now be compiled without linking to the actual Tcl stubs library.
212	189	** In that case, this function will be used to perform those steps that would
213	190	** normally be performed within the Tcl stubs library.
214		- */
	191	+*/
215	192	static int initTclStubs(
216	193	Th_Interp *interp,
217	194	Tcl_Interp *tclInterp
218	195	){
219	196	tclStubsPtr = ((struct PrivateTclInterp *)tclInterp)->stubTable;
		@@ -231,24 +208,56 @@
231	208	return TH_ERROR;
232	209	}
233	210	return TH_OK;
234	211	}
235	212	#endif /* defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS) */
	213	+
	214	+/*
	215	+** Is the loaded version of Tcl one where querying and/or calling the objProc
	216	+** for a command does not work for some reason? The following special cases
	217	+** are currently handled by this function:
	218	+**
	219	+** 1. All versions of Tcl 8.4 have a bug that causes a crash when calling into
	220	+** the Tcl_GetCommandFromObj function via stubs (i.e. the stubs table entry
	221	+** is NULL).
	222	+**
	223	+** 2. Various beta builds of Tcl 8.6, namely 1 and 2, have an NRE-specific bug
	224	+** in Tcl_EvalObjCmd (SF bug #3399564) that cause a panic when calling into
	225	+** the objProc directly.
	226	+**
	227	+** For both of the above cases, the Tcl_EvalObjv function must be used instead
	228	+** of the more direct route of querying and calling the objProc directly.
	229	+*/
	230	+static int canUseObjProc(){
	231	+ int major = -1, minor = -1, patchLevel = -1, type = -1;
	232	+
	233	+ Tcl_GetVersion(&major, &minor, &patchLevel, &type);
	234	+ if( major<0 \|\| minor<0 \|\| patchLevel<0 \|\| type<0 ){
	235	+ return 0; /* NOTE: Invalid version info, assume bad. */
	236	+ }
	237	+ if( major==8 && minor==4 ){
	238	+ return 0; /* NOTE: Disabled on Tcl 8.4, missing public API. */
	239	+ }
	240	+ if( major==8 && minor==6 && type==TCL_BETA_RELEASE && patchLevel<3 ){
	241	+ return 0; /* NOTE: Disabled on Tcl 8.6b1/b2, SF bug #3399564. */
	242	+ }
	243	+ return 1; /* NOTE: For all other cases, assume good. */
	244	+}
236	245
237	246	/*
238	247	** Creates and initializes a Tcl interpreter for use with the specified TH1
239	248	** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
240	249	** by the caller. This must be declared here because quite a few functions in
241	250	** this file need to use it before it can be defined.
242		- */
	251	+*/
243	252	static int createTclInterp(Th_Interp interp, void pContext);
244	253
245	254	/*
246	255	** Returns the Tcl interpreter result as a string with the associated length.
247	256	** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
248	257	** If the length pointer is NULL, the length will not be stored.
249		- */
	258	+*/
250	259	static char *getTclResult(
251	260	Tcl_Interp *pInterp,
252	261	int *pN
253	262	){
254	263	Tcl_Obj *resultPtr;
		@@ -274,11 +283,13 @@
274	283	char *argv; / Full copy of the original arguments. */
275	284	void library; / The Tcl library module handle. */
276	285	tcl_FindExecutableProc xFindExecutable; / Tcl_FindExecutable() pointer. */
277	286	tcl_CreateInterpProc xCreateInterp; / Tcl_CreateInterp() pointer. */
278	287	tcl_DeleteInterpProc xDeleteInterp; / Tcl_DeleteInterp() pointer. */
	288	+ tcl_FinalizeProc xFinalize; / Tcl_Finalize() pointer. */
279	289	Tcl_Interp interp; / The on-demand created Tcl interpreter. */
	290	+ int useObjProc; /* Non-zero if an objProc can be called directly. */
280	291	char setup; / The optional Tcl setup script. */
281	292	tcl_NotifyProc xPreEval; / Optional, called before Tcl_Eval(). /
282	293	void pPreContext; / Optional, provided to xPreEval(). */
283	294	tcl_NotifyProc xPostEval; / Optional, called after Tcl_Eval(). /
284	295	void pPostContext; / Optional, provided to xPostEval(). */
		@@ -443,20 +454,13 @@
443	454	int argc,
444	455	const char **argv,
445	456	int *argl
446	457	){
447	458	Tcl_Interp *tclInterp;
448		-#if !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV
449		- Tcl_Command command;
450		- Tcl_CmdInfo cmdInfo;
451		-#endif /* !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV */
452	459	int rc = TH_OK;
453	460	int nResult;
454	461	const char *zResult;
455		-#if !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV
456		- Tcl_Obj *objPtr;
457		-#endif /* !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV */
458	462	USE_ARGV_TO_OBJV();
459	463
460	464	if( createTclInterp(interp, ctx)!=TH_OK ){
461	465	return TH_ERROR;
462	466	}
		@@ -472,35 +476,40 @@
472	476	if( rc!=TH_OK ){
473	477	return rc;
474	478	}
475	479	Tcl_Preserve((ClientData)tclInterp);
476	480	#if !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV
477		- objPtr = Tcl_NewStringObj(argv[1], argl[1]);
478		- Tcl_IncrRefCount(objPtr);
479		- command = Tcl_GetCommandFromObj(tclInterp, objPtr);
480		- if( !command \|\| Tcl_GetCommandInfoFromToken(command, &cmdInfo)==0 ){
481		- Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
482		- Tcl_DecrRefCount(objPtr);
483		- Tcl_Release((ClientData)tclInterp);
484		- return TH_ERROR;
485		- }
486		- if( !cmdInfo.objProc ){
487		- Th_ErrorMessage(interp, "cannot invoke Tcl command:", argv[1], argl[1]);
488		- Tcl_DecrRefCount(objPtr);
489		- Tcl_Release((ClientData)tclInterp);
490		- return TH_ERROR;
491		- }
492		- Tcl_DecrRefCount(objPtr);
493		-#endif /* !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV */
494		- COPY_ARGV_TO_OBJV();
495		-#if defined(USE_TCL_EVALOBJV) && USE_TCL_EVALOBJV
496		- rc = Tcl_EvalObjv(tclInterp, objc, objv, 0);
497		-#else
498		- Tcl_ResetResult(tclInterp);
499		- rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
500		-#endif /* defined(USE_TCL_EVALOBJV) && USE_TCL_EVALOBJV */
501		- FREE_ARGV_TO_OBJV();
	481	+ if( GET_CTX_TCL_USEOBJPROC(ctx) ){
	482	+ Tcl_Command command;
	483	+ Tcl_CmdInfo cmdInfo;
	484	+ Tcl_Obj *objPtr = Tcl_NewStringObj(argv[1], argl[1]);
	485	+ Tcl_IncrRefCount(objPtr);
	486	+ command = Tcl_GetCommandFromObj(tclInterp, objPtr);
	487	+ if( !command \|\| Tcl_GetCommandInfoFromToken(command, &cmdInfo)==0 ){
	488	+ Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
	489	+ Tcl_DecrRefCount(objPtr);
	490	+ Tcl_Release((ClientData)tclInterp);
	491	+ return TH_ERROR;
	492	+ }
	493	+ if( !cmdInfo.objProc ){
	494	+ Th_ErrorMessage(interp, "cannot invoke Tcl command:", argv[1], argl[1]);
	495	+ Tcl_DecrRefCount(objPtr);
	496	+ Tcl_Release((ClientData)tclInterp);
	497	+ return TH_ERROR;
	498	+ }
	499	+ Tcl_DecrRefCount(objPtr);
	500	+ COPY_ARGV_TO_OBJV();
	501	+ Tcl_ResetResult(tclInterp);
	502	+ rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
	503	+ FREE_ARGV_TO_OBJV();
	504	+ }else
	505	+#endif /* !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV */
	506	+ {
	507	+ COPY_ARGV_TO_OBJV();
	508	+ rc = Tcl_EvalObjv(tclInterp, objc, objv, 0);
	509	+ FREE_ARGV_TO_OBJV();
	510	+ }
502	511	zResult = getTclResult(tclInterp, &nResult);
503	512	Th_SetResult(interp, zResult, nResult);
504	513	Tcl_Release((ClientData)tclInterp);
505	514	rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
506	515	return rc;
		@@ -586,11 +595,11 @@
586	595	};
587	596
588	597	/*
589	598	** Called if the Tcl interpreter is deleted. Removes the Tcl integration
590	599	** commands from the TH1 interpreter.
591		- */
	600	+*/
592	601	static void Th1DeleteProc(
593	602	ClientData clientData,
594	603	Tcl_Interp *interp
595	604	){
596	605	int i;
		@@ -607,23 +616,25 @@
607	616	** When Tcl stubs support is enabled, attempts to dynamically load the Tcl
608	617	** shared library and fetch the function pointers necessary to create an
609	618	** interpreter and initialize the stubs mechanism; otherwise, simply setup
610	619	** the function pointers provided by the caller with the statically linked
611	620	** functions.
612		- */
	621	+*/
613	622	static int loadTcl(
614	623	Th_Interp *interp,
615	624	void **pLibrary,
616	625	tcl_FindExecutableProc **pxFindExecutable,
617	626	tcl_CreateInterpProc **pxCreateInterp,
618		- tcl_DeleteInterpProc **pxDeleteInterp
	627	+ tcl_DeleteInterpProc **pxDeleteInterp,
	628	+ tcl_FinalizeProc **pxFinalize
619	629	){
620	630	#if defined(USE_TCL_STUBS)
621	631	char fileName[] = TCL_LIBRARY_NAME;
622	632	#endif /* defined(USE_TCL_STUBS) */
623	633
624		- if( !pLibrary \|\| !pxFindExecutable \|\| !pxCreateInterp \|\| !pxDeleteInterp ){
	634	+ if( !pLibrary \|\| !pxFindExecutable \|\| !pxCreateInterp \|\|
	635	+ !pxDeleteInterp \|\| !pxFinalize ){
625	636	Th_ErrorMessage(interp,
626	637	"invalid Tcl loader argument(s)", (const char *)"", 0);
627	638	return TH_ERROR;
628	639	}
629	640	#if defined(USE_TCL_STUBS)
		@@ -631,10 +642,11 @@
631	642	void *library = dlopen(fileName, RTLD_NOW \| RTLD_GLOBAL);
632	643	if( library ){
633	644	tcl_FindExecutableProc *xFindExecutable;
634	645	tcl_CreateInterpProc *xCreateInterp;
635	646	tcl_DeleteInterpProc *xDeleteInterp;
	647	+ tcl_FinalizeProc *xFinalize;
636	648	const char *procName = TCL_FINDEXECUTABLE_NAME;
637	649	xFindExecutable = (tcl_FindExecutableProc *)dlsym(library, procName + 1);
638	650	if( !xFindExecutable ){
639	651	xFindExecutable = (tcl_FindExecutableProc *)dlsym(library, procName);
640	652	}
		@@ -663,15 +675,27 @@
663	675	if( !xDeleteInterp ){
664	676	Th_ErrorMessage(interp,
665	677	"could not locate Tcl_DeleteInterp", (const char *)"", 0);
666	678	dlclose(library);
667	679	return TH_ERROR;
	680	+ }
	681	+ procName = TCL_FINALIZE_NAME;
	682	+ xFinalize = (tcl_FinalizeProc *)dlsym(library, procName + 1);
	683	+ if( !xFinalize ){
	684	+ xFinalize = (tcl_FinalizeProc *)dlsym(library, procName);
	685	+ }
	686	+ if( !xFinalize ){
	687	+ Th_ErrorMessage(interp,
	688	+ "could not locate Tcl_Finalize", (const char *)"", 0);
	689	+ dlclose(library);
	690	+ return TH_ERROR;
668	691	}
669	692	*pLibrary = library;
670	693	*pxFindExecutable = xFindExecutable;
671	694	*pxCreateInterp = xCreateInterp;
672	695	*pxDeleteInterp = xDeleteInterp;
	696	+ *pxFinalize = xFinalize;
673	697	return TH_OK;
674	698	}
675	699	} while( --fileName[TCL_MINOR_OFFSET]>'3' ); /* Tcl 8.4+ */
676	700	fileName[TCL_MINOR_OFFSET] = 'x';
677	701	Th_ErrorMessage(interp,
		@@ -681,18 +705,19 @@
681	705	#else
682	706	*pLibrary = 0;
683	707	*pxFindExecutable = Tcl_FindExecutable;
684	708	*pxCreateInterp = Tcl_CreateInterp;
685	709	*pxDeleteInterp = Tcl_DeleteInterp;
	710	+ *pxFinalize = Tcl_Finalize;
686	711	return TH_OK;
687	712	#endif /* defined(USE_TCL_STUBS) */
688	713	}
689	714
690	715	/*
691	716	** Sets the "argv0", "argc", and "argv" script variables in the Tcl interpreter
692	717	** based on the supplied command line arguments.
693		- */
	718	+*/
694	719	static int setTclArguments(
695	720	Tcl_Interp *pInterp,
696	721	int argc,
697	722	char **argv
698	723	){
		@@ -746,11 +771,11 @@
746	771
747	772	/*
748	773	** Creates and initializes a Tcl interpreter for use with the specified TH1
749	774	** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
750	775	** by the caller.
751		- */
	776	+*/
752	777	static int createTclInterp(
753	778	Th_Interp *interp,
754	779	void *pContext
755	780	){
756	781	struct TclContext tclContext = (struct TclContext )pContext;
		@@ -767,11 +792,12 @@
767	792	}
768	793	if ( tclContext->interp ){
769	794	return TH_OK;
770	795	}
771	796	if( loadTcl(interp, &tclContext->library, &tclContext->xFindExecutable,
772		- &tclContext->xCreateInterp, &tclContext->xDeleteInterp)!=TH_OK ){
	797	+ &tclContext->xCreateInterp, &tclContext->xDeleteInterp,
	798	+ &tclContext->xFinalize)!=TH_OK ){
773	799	return TH_ERROR;
774	800	}
775	801	argc = tclContext->argc;
776	802	argv = tclContext->argv;
777	803	if( argc>0 && argv ){
		@@ -821,10 +847,15 @@
821	847	"Tcl error setting arguments:", Tcl_GetStringResult(tclInterp), -1);
822	848	Tcl_DeleteInterp(tclInterp);
823	849	tclContext->interp = tclInterp = 0;
824	850	return TH_ERROR;
825	851	}
	852	+ /*
	853	+ ** Determine if an objProc can be called directly for a Tcl command invoked
	854	+ ** via the tclInvoke TH1 command.
	855	+ */
	856	+ tclContext->useObjProc = canUseObjProc();
826	857	/* Add the TH1 integration commands to Tcl. */
827	858	Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
828	859	Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
829	860	Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
830	861	/* If necessary, evaluate the custom Tcl setup script. */
		@@ -836,10 +867,68 @@
836	867	tclContext->interp = tclInterp = 0;
837	868	return TH_ERROR;
838	869	}
839	870	return TH_OK;
840	871	}
	872	+
	873	+/*
	874	+** Finalizes and unloads the previously loaded Tcl library, if applicable.
	875	+*/
	876	+int unloadTcl(
	877	+ Th_Interp *interp,
	878	+ void *pContext
	879	+){
	880	+ struct TclContext tclContext = (struct TclContext )pContext;
	881	+ Tcl_Interp *tclInterp;
	882	+ tcl_FinalizeProc *xFinalize;
	883	+#if defined(USE_TCL_STUBS)
	884	+ void *library;
	885	+#endif /* defined(USE_TCL_STUBS) */
	886	+
	887	+ if ( !tclContext ){
	888	+ Th_ErrorMessage(interp,
	889	+ "invalid Tcl context", (const char *)"", 0);
	890	+ return TH_ERROR;
	891	+ }
	892	+ /*
	893	+ ** Grab the Tcl_Finalize function pointer prior to deleting the Tcl
	894	+ ** interpreter because the memory backing the Tcl stubs table will
	895	+ ** be going away.
	896	+ */
	897	+ xFinalize = tclContext->xFinalize;
	898	+ /*
	899	+ ** If the Tcl interpreter has been created, formally delete it now.
	900	+ */
	901	+ tclInterp = tclContext->interp;
	902	+ if ( tclInterp ){
	903	+ Tcl_DeleteInterp(tclInterp);
	904	+ tclContext->interp = tclInterp = 0;
	905	+ }
	906	+ /*
	907	+ ** If the Tcl library is not finalized prior to unloading it, a deadlock
	908	+ ** can occur in some circumstances (i.e. the [clock] thread is running).
	909	+ */
	910	+ if( xFinalize ) xFinalize();
	911	+#if defined(USE_TCL_STUBS)
	912	+ /*
	913	+ ** If Tcl is compiled on Windows using the latest MinGW, Fossil can crash
	914	+ ** when exiting while a stubs-enabled Tcl is still loaded. This is due to
	915	+ ** a bug in MinGW, see:
	916	+ **
	917	+ ** http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724
	918	+ **
	919	+ ** The workaround is to manually unload the loaded Tcl library prior to
	920	+ ** exiting the process.
	921	+ */
	922	+ library = tclContext->library;
	923	+ if( library ){
	924	+ dlclose(library);
	925	+ tclContext->library = library = 0;
	926	+ }
	927	+#endif /* defined(USE_TCL_STUBS) */
	928	+ return TH_OK;
	929	+}
841	930
842	931	/*
843	932	** Register the Tcl language commands with interpreter interp.
844	933	** Usually this is called soon after interpreter creation.
845	934	*/
846	935

	--- src/th_tcl.c
	+++ src/th_tcl.c
	@@ -23,48 +23,14 @@
23	#ifdef FOSSIL_ENABLE_TCL
24
25	#include "th.h"
26	#include "tcl.h"
27
28	/*
29	** Has the decision about whether or not to use Tcl_EvalObjv already been made
30	** via the Makefile?
31	*/
32	#if !defined(USE_TCL_EVALOBJV)
33	/*
34	** Are we being compiled against Tcl 8.6b1 or b2? This check is [mostly]
35	** wrong for at the following reason:
36	**
37	** 1. Technically, this check is completely useless when the stubs mechanism
38	** is in use. In that case, a runtime version check would be required and
39	** that has not been implemented.
40	**
41	** However, if a particular user compiles and runs against Tcl 8.6b1 or b2,
42	** this will cause a fallback to using the "conservative" method of directly
43	** invoking a Tcl command. In that case, potential crashes will be avoided if
44	** the user just so happened to compile or run against Tcl 8.6b1 or b2.
45	*/
46	#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION == 6) && \
47	(TCL_RELEASE_LEVEL == TCL_BETA_RELEASE) && (TCL_RELEASE_SERIAL < 3)
48	/*
49	** Workaround NRE-specific issue in Tcl_EvalObjCmd (SF bug #3399564) by using
50	** Tcl_EvalObjv instead of invoking the objProc directly.
51	*/
52	# define USE_TCL_EVALOBJV (1)
53	#else
54	/*
55	** We should be able to safely use Tcl_GetCommandInfoFromToken, when the need
56	** arises, to invoke a specific Tcl command "directly" with some arguments.
57	*/
58	# define USE_TCL_EVALOBJV (0)
59	#endif /* (TCL_MAJOR_VERSION > 8) ... */
60	#endif /* !defined(USE_TCL_EVALOBJV) */
61
62	/*
63	** These macros are designed to reduce the redundant code required to marshal
64	** arguments from TH1 to Tcl.
65	*/
66	#define USE_ARGV_TO_OBJV() \
67	int objc; \
68	Tcl_Obj **objv; \
69	int i;
70
	@@ -83,18 +49,25 @@
83	ckfree((char *)objv);
84
85	/*
86	** Fetch the Tcl interpreter from the specified void pointer, cast to a Tcl
87	** context.
88	*/
89	#define GET_CTX_TCL_INTERP(ctx) \
90	((struct TclContext *)(ctx))->interp
91







92	/*
93	** Define the Tcl shared library name, some exported function names, and some
94	** cross-platform macros for use with the Tcl stubs mechanism, when enabled.
95	*/
96	#if defined(USE_TCL_STUBS)
97	# if defined(_WIN32)
98	# define WIN32_LEAN_AND_MEAN
99	# include <windows.h>
100	# ifndef TCL_LIBRARY_NAME
	@@ -144,33 +117,37 @@
144	# define TCL_CREATEINTERP_NAME "_Tcl_CreateInterp"
145	# endif
146	# ifndef TCL_DELETEINTERP_NAME
147	# define TCL_DELETEINTERP_NAME "_Tcl_DeleteInterp"
148	# endif



149	#endif /* defined(USE_TCL_STUBS) */
150
151	/*
152	** The function types for Tcl_FindExecutable and Tcl_CreateInterp are needed
153	** when the Tcl library is being loaded dynamically by a stubs-enabled
154	** application (i.e. the inverse of using a stubs-enabled package). These are
155	** the only Tcl API functions that MUST be called prior to being able to call
156	** Tcl_InitStubs (i.e. because it requires a Tcl interpreter). For complete
157	** cleanup if the Tcl stubs initialization fails somehow, the Tcl_DeleteInterp
158	** function type is also required.
159	*/
160	typedef void (tcl_FindExecutableProc) (const char * argv0);
161	typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
162	typedef void (tcl_DeleteInterpProc) (Tcl_Interp *interp);

163
164	/*
165	** The function types for the "hook" functions to be called before and after a
166	** TH1 command makes a call to evaluate a Tcl script. If the "pre" function
167	** returns anything but TH_OK, then evaluation of the Tcl script is skipped and
168	** that value is used as the return code. If the "post" function returns
169	** anything other than its rc argument, that will become the new return code
170	** for the command.
171	*/
172	typedef int (tcl_NotifyProc) (
173	void pContext, / The context for this notification. */
174	Th_Interp interp, / The TH1 interpreter being used. */
175	void ctx, / The original TH1 command context. */
176	int argc, /* Number of arguments for the TH1 command. */
	@@ -181,27 +158,27 @@
181
182	/*
183	** Are we using our own private implementation of the Tcl stubs mechanism? If
184	** this is enabled, it prevents the user from having to link against the Tcl
185	** stubs library for the target platform, which may not be readily available.
186	*/
187	#if defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS)
188	/*
189	** HACK: Using some preprocessor magic and a private static variable, redirect
190	** the Tcl API calls [found within this file] to the function pointers
191	** that will be contained in our private Tcl stubs table. This takes
192	** advantage of the fact that the Tcl headers always define the Tcl API
193	** functions in terms of the "tclStubsPtr" variable.
194	*/
195	#define tclStubsPtr privateTclStubsPtr
196	static const TclStubs *tclStubsPtr = NULL;
197
198	/*
199	** Create a Tcl interpreter structure that mirrors just enough fields to get
200	** it up and running successfully with our private implementation of the Tcl
201	** stubs mechanism.
202	*/
203	struct PrivateTclInterp {
204	char *result;
205	Tcl_FreeProc *freeProc;
206	int errorLine;
207	const struct TclStubs *stubTable;
	@@ -209,11 +186,11 @@
209
210	/*
211	** Fossil can now be compiled without linking to the actual Tcl stubs library.
212	** In that case, this function will be used to perform those steps that would
213	** normally be performed within the Tcl stubs library.
214	*/
215	static int initTclStubs(
216	Th_Interp *interp,
217	Tcl_Interp *tclInterp
218	){
219	tclStubsPtr = ((struct PrivateTclInterp *)tclInterp)->stubTable;
	@@ -231,24 +208,56 @@
231	return TH_ERROR;
232	}
233	return TH_OK;
234	}
235	#endif /* defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS) */
































236
237	/*
238	** Creates and initializes a Tcl interpreter for use with the specified TH1
239	** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
240	** by the caller. This must be declared here because quite a few functions in
241	** this file need to use it before it can be defined.
242	*/
243	static int createTclInterp(Th_Interp interp, void pContext);
244
245	/*
246	** Returns the Tcl interpreter result as a string with the associated length.
247	** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
248	** If the length pointer is NULL, the length will not be stored.
249	*/
250	static char *getTclResult(
251	Tcl_Interp *pInterp,
252	int *pN
253	){
254	Tcl_Obj *resultPtr;
	@@ -274,11 +283,13 @@
274	char *argv; / Full copy of the original arguments. */
275	void library; / The Tcl library module handle. */
276	tcl_FindExecutableProc xFindExecutable; / Tcl_FindExecutable() pointer. */
277	tcl_CreateInterpProc xCreateInterp; / Tcl_CreateInterp() pointer. */
278	tcl_DeleteInterpProc xDeleteInterp; / Tcl_DeleteInterp() pointer. */

279	Tcl_Interp interp; / The on-demand created Tcl interpreter. */

280	char setup; / The optional Tcl setup script. */
281	tcl_NotifyProc xPreEval; / Optional, called before Tcl_Eval(). /
282	void pPreContext; / Optional, provided to xPreEval(). */
283	tcl_NotifyProc xPostEval; / Optional, called after Tcl_Eval(). /
284	void pPostContext; / Optional, provided to xPostEval(). */
	@@ -443,20 +454,13 @@
443	int argc,
444	const char **argv,
445	int *argl
446	){
447	Tcl_Interp *tclInterp;
448	#if !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV
449	Tcl_Command command;
450	Tcl_CmdInfo cmdInfo;
451	#endif /* !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV */
452	int rc = TH_OK;
453	int nResult;
454	const char *zResult;
455	#if !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV
456	Tcl_Obj *objPtr;
457	#endif /* !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV */
458	USE_ARGV_TO_OBJV();
459
460	if( createTclInterp(interp, ctx)!=TH_OK ){
461	return TH_ERROR;
462	}
	@@ -472,35 +476,40 @@
472	if( rc!=TH_OK ){
473	return rc;
474	}
475	Tcl_Preserve((ClientData)tclInterp);
476	#if !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV
477	objPtr = Tcl_NewStringObj(argv[1], argl[1]);
478	Tcl_IncrRefCount(objPtr);
479	command = Tcl_GetCommandFromObj(tclInterp, objPtr);
480	if( !command \|\| Tcl_GetCommandInfoFromToken(command, &cmdInfo)==0 ){
481	Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
482	Tcl_DecrRefCount(objPtr);
483	Tcl_Release((ClientData)tclInterp);
484	return TH_ERROR;
485	}
486	if( !cmdInfo.objProc ){
487	Th_ErrorMessage(interp, "cannot invoke Tcl command:", argv[1], argl[1]);
488	Tcl_DecrRefCount(objPtr);
489	Tcl_Release((ClientData)tclInterp);
490	return TH_ERROR;
491	}
492	Tcl_DecrRefCount(objPtr);
493	#endif /* !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV */
494	COPY_ARGV_TO_OBJV();
495	#if defined(USE_TCL_EVALOBJV) && USE_TCL_EVALOBJV
496	rc = Tcl_EvalObjv(tclInterp, objc, objv, 0);
497	#else
498	Tcl_ResetResult(tclInterp);
499	rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
500	#endif /* defined(USE_TCL_EVALOBJV) && USE_TCL_EVALOBJV */
501	FREE_ARGV_TO_OBJV();





502	zResult = getTclResult(tclInterp, &nResult);
503	Th_SetResult(interp, zResult, nResult);
504	Tcl_Release((ClientData)tclInterp);
505	rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
506	return rc;
	@@ -586,11 +595,11 @@
586	};
587
588	/*
589	** Called if the Tcl interpreter is deleted. Removes the Tcl integration
590	** commands from the TH1 interpreter.
591	*/
592	static void Th1DeleteProc(
593	ClientData clientData,
594	Tcl_Interp *interp
595	){
596	int i;
	@@ -607,23 +616,25 @@
607	** When Tcl stubs support is enabled, attempts to dynamically load the Tcl
608	** shared library and fetch the function pointers necessary to create an
609	** interpreter and initialize the stubs mechanism; otherwise, simply setup
610	** the function pointers provided by the caller with the statically linked
611	** functions.
612	*/
613	static int loadTcl(
614	Th_Interp *interp,
615	void **pLibrary,
616	tcl_FindExecutableProc **pxFindExecutable,
617	tcl_CreateInterpProc **pxCreateInterp,
618	tcl_DeleteInterpProc **pxDeleteInterp

619	){
620	#if defined(USE_TCL_STUBS)
621	char fileName[] = TCL_LIBRARY_NAME;
622	#endif /* defined(USE_TCL_STUBS) */
623
624	if( !pLibrary \|\| !pxFindExecutable \|\| !pxCreateInterp \|\| !pxDeleteInterp ){

625	Th_ErrorMessage(interp,
626	"invalid Tcl loader argument(s)", (const char *)"", 0);
627	return TH_ERROR;
628	}
629	#if defined(USE_TCL_STUBS)
	@@ -631,10 +642,11 @@
631	void *library = dlopen(fileName, RTLD_NOW \| RTLD_GLOBAL);
632	if( library ){
633	tcl_FindExecutableProc *xFindExecutable;
634	tcl_CreateInterpProc *xCreateInterp;
635	tcl_DeleteInterpProc *xDeleteInterp;

636	const char *procName = TCL_FINDEXECUTABLE_NAME;
637	xFindExecutable = (tcl_FindExecutableProc *)dlsym(library, procName + 1);
638	if( !xFindExecutable ){
639	xFindExecutable = (tcl_FindExecutableProc *)dlsym(library, procName);
640	}
	@@ -663,15 +675,27 @@
663	if( !xDeleteInterp ){
664	Th_ErrorMessage(interp,
665	"could not locate Tcl_DeleteInterp", (const char *)"", 0);
666	dlclose(library);
667	return TH_ERROR;











668	}
669	*pLibrary = library;
670	*pxFindExecutable = xFindExecutable;
671	*pxCreateInterp = xCreateInterp;
672	*pxDeleteInterp = xDeleteInterp;

673	return TH_OK;
674	}
675	} while( --fileName[TCL_MINOR_OFFSET]>'3' ); /* Tcl 8.4+ */
676	fileName[TCL_MINOR_OFFSET] = 'x';
677	Th_ErrorMessage(interp,
	@@ -681,18 +705,19 @@
681	#else
682	*pLibrary = 0;
683	*pxFindExecutable = Tcl_FindExecutable;
684	*pxCreateInterp = Tcl_CreateInterp;
685	*pxDeleteInterp = Tcl_DeleteInterp;

686	return TH_OK;
687	#endif /* defined(USE_TCL_STUBS) */
688	}
689
690	/*
691	** Sets the "argv0", "argc", and "argv" script variables in the Tcl interpreter
692	** based on the supplied command line arguments.
693	*/
694	static int setTclArguments(
695	Tcl_Interp *pInterp,
696	int argc,
697	char **argv
698	){
	@@ -746,11 +771,11 @@
746
747	/*
748	** Creates and initializes a Tcl interpreter for use with the specified TH1
749	** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
750	** by the caller.
751	*/
752	static int createTclInterp(
753	Th_Interp *interp,
754	void *pContext
755	){
756	struct TclContext tclContext = (struct TclContext )pContext;
	@@ -767,11 +792,12 @@
767	}
768	if ( tclContext->interp ){
769	return TH_OK;
770	}
771	if( loadTcl(interp, &tclContext->library, &tclContext->xFindExecutable,
772	&tclContext->xCreateInterp, &tclContext->xDeleteInterp)!=TH_OK ){

773	return TH_ERROR;
774	}
775	argc = tclContext->argc;
776	argv = tclContext->argv;
777	if( argc>0 && argv ){
	@@ -821,10 +847,15 @@
821	"Tcl error setting arguments:", Tcl_GetStringResult(tclInterp), -1);
822	Tcl_DeleteInterp(tclInterp);
823	tclContext->interp = tclInterp = 0;
824	return TH_ERROR;
825	}





826	/* Add the TH1 integration commands to Tcl. */
827	Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
828	Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
829	Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
830	/* If necessary, evaluate the custom Tcl setup script. */
	@@ -836,10 +867,68 @@
836	tclContext->interp = tclInterp = 0;
837	return TH_ERROR;
838	}
839	return TH_OK;
840	}


























































841
842	/*
843	** Register the Tcl language commands with interpreter interp.
844	** Usually this is called soon after interpreter creation.
845	*/
846

	--- src/th_tcl.c
	+++ src/th_tcl.c
	@@ -23,48 +23,14 @@
23	#ifdef FOSSIL_ENABLE_TCL
24
25	#include "th.h"
26	#include "tcl.h"
27


































28	/*
29	** These macros are designed to reduce the redundant code required to marshal
30	** arguments from TH1 to Tcl.
31	*/
32	#define USE_ARGV_TO_OBJV() \
33	int objc; \
34	Tcl_Obj **objv; \
35	int i;
36
	@@ -83,18 +49,25 @@
49	ckfree((char *)objv);
50
51	/*
52	** Fetch the Tcl interpreter from the specified void pointer, cast to a Tcl
53	** context.
54	*/
55	#define GET_CTX_TCL_INTERP(ctx) \
56	((struct TclContext *)(ctx))->interp
57
58	/*
59	** Fetch the (logically boolean) value from the specified void pointer that
60	** indicates whether or not we can/should use direct objProc calls.
61	*/
62	#define GET_CTX_TCL_USEOBJPROC(ctx) \
63	((struct TclContext *)(ctx))->useObjProc
64
65	/*
66	** Define the Tcl shared library name, some exported function names, and some
67	** cross-platform macros for use with the Tcl stubs mechanism, when enabled.
68	*/
69	#if defined(USE_TCL_STUBS)
70	# if defined(_WIN32)
71	# define WIN32_LEAN_AND_MEAN
72	# include <windows.h>
73	# ifndef TCL_LIBRARY_NAME
	@@ -144,33 +117,37 @@
117	# define TCL_CREATEINTERP_NAME "_Tcl_CreateInterp"
118	# endif
119	# ifndef TCL_DELETEINTERP_NAME
120	# define TCL_DELETEINTERP_NAME "_Tcl_DeleteInterp"
121	# endif
122	# ifndef TCL_FINALIZE_NAME
123	# define TCL_FINALIZE_NAME "_Tcl_Finalize"
124	# endif
125	#endif /* defined(USE_TCL_STUBS) */
126
127	/*
128	** The function types for Tcl_FindExecutable and Tcl_CreateInterp are needed
129	** when the Tcl library is being loaded dynamically by a stubs-enabled
130	** application (i.e. the inverse of using a stubs-enabled package). These are
131	** the only Tcl API functions that MUST be called prior to being able to call
132	** Tcl_InitStubs (i.e. because it requires a Tcl interpreter). For complete
133	** cleanup if the Tcl stubs initialization fails somehow, the Tcl_DeleteInterp
134	** and Tcl_Finalize function types are also required.
135	*/
136	typedef void (tcl_FindExecutableProc) (const char * argv0);
137	typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
138	typedef void (tcl_DeleteInterpProc) (Tcl_Interp *interp);
139	typedef void (tcl_FinalizeProc) (void);
140
141	/*
142	** The function types for the "hook" functions to be called before and after a
143	** TH1 command makes a call to evaluate a Tcl script. If the "pre" function
144	** returns anything but TH_OK, then evaluation of the Tcl script is skipped and
145	** that value is used as the return code. If the "post" function returns
146	** anything other than its rc argument, that will become the new return code
147	** for the command.
148	*/
149	typedef int (tcl_NotifyProc) (
150	void pContext, / The context for this notification. */
151	Th_Interp interp, / The TH1 interpreter being used. */
152	void ctx, / The original TH1 command context. */
153	int argc, /* Number of arguments for the TH1 command. */
	@@ -181,27 +158,27 @@
158
159	/*
160	** Are we using our own private implementation of the Tcl stubs mechanism? If
161	** this is enabled, it prevents the user from having to link against the Tcl
162	** stubs library for the target platform, which may not be readily available.
163	*/
164	#if defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS)
165	/*
166	** HACK: Using some preprocessor magic and a private static variable, redirect
167	** the Tcl API calls [found within this file] to the function pointers
168	** that will be contained in our private Tcl stubs table. This takes
169	** advantage of the fact that the Tcl headers always define the Tcl API
170	** functions in terms of the "tclStubsPtr" variable.
171	*/
172	#define tclStubsPtr privateTclStubsPtr
173	static const TclStubs *tclStubsPtr = NULL;
174
175	/*
176	** Create a Tcl interpreter structure that mirrors just enough fields to get
177	** it up and running successfully with our private implementation of the Tcl
178	** stubs mechanism.
179	*/
180	struct PrivateTclInterp {
181	char *result;
182	Tcl_FreeProc *freeProc;
183	int errorLine;
184	const struct TclStubs *stubTable;
	@@ -209,11 +186,11 @@
186
187	/*
188	** Fossil can now be compiled without linking to the actual Tcl stubs library.
189	** In that case, this function will be used to perform those steps that would
190	** normally be performed within the Tcl stubs library.
191	*/
192	static int initTclStubs(
193	Th_Interp *interp,
194	Tcl_Interp *tclInterp
195	){
196	tclStubsPtr = ((struct PrivateTclInterp *)tclInterp)->stubTable;
	@@ -231,24 +208,56 @@
208	return TH_ERROR;
209	}
210	return TH_OK;
211	}
212	#endif /* defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS) */
213
214	/*
215	** Is the loaded version of Tcl one where querying and/or calling the objProc
216	** for a command does not work for some reason? The following special cases
217	** are currently handled by this function:
218	**
219	** 1. All versions of Tcl 8.4 have a bug that causes a crash when calling into
220	** the Tcl_GetCommandFromObj function via stubs (i.e. the stubs table entry
221	** is NULL).
222	**
223	** 2. Various beta builds of Tcl 8.6, namely 1 and 2, have an NRE-specific bug
224	** in Tcl_EvalObjCmd (SF bug #3399564) that cause a panic when calling into
225	** the objProc directly.
226	**
227	** For both of the above cases, the Tcl_EvalObjv function must be used instead
228	** of the more direct route of querying and calling the objProc directly.
229	*/
230	static int canUseObjProc(){
231	int major = -1, minor = -1, patchLevel = -1, type = -1;
232
233	Tcl_GetVersion(&major, &minor, &patchLevel, &type);
234	if( major<0 \|\| minor<0 \|\| patchLevel<0 \|\| type<0 ){
235	return 0; /* NOTE: Invalid version info, assume bad. */
236	}
237	if( major==8 && minor==4 ){
238	return 0; /* NOTE: Disabled on Tcl 8.4, missing public API. */
239	}
240	if( major==8 && minor==6 && type==TCL_BETA_RELEASE && patchLevel<3 ){
241	return 0; /* NOTE: Disabled on Tcl 8.6b1/b2, SF bug #3399564. */
242	}
243	return 1; /* NOTE: For all other cases, assume good. */
244	}
245
246	/*
247	** Creates and initializes a Tcl interpreter for use with the specified TH1
248	** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
249	** by the caller. This must be declared here because quite a few functions in
250	** this file need to use it before it can be defined.
251	*/
252	static int createTclInterp(Th_Interp interp, void pContext);
253
254	/*
255	** Returns the Tcl interpreter result as a string with the associated length.
256	** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
257	** If the length pointer is NULL, the length will not be stored.
258	*/
259	static char *getTclResult(
260	Tcl_Interp *pInterp,
261	int *pN
262	){
263	Tcl_Obj *resultPtr;
	@@ -274,11 +283,13 @@
283	char *argv; / Full copy of the original arguments. */
284	void library; / The Tcl library module handle. */
285	tcl_FindExecutableProc xFindExecutable; / Tcl_FindExecutable() pointer. */
286	tcl_CreateInterpProc xCreateInterp; / Tcl_CreateInterp() pointer. */
287	tcl_DeleteInterpProc xDeleteInterp; / Tcl_DeleteInterp() pointer. */
288	tcl_FinalizeProc xFinalize; / Tcl_Finalize() pointer. */
289	Tcl_Interp interp; / The on-demand created Tcl interpreter. */
290	int useObjProc; /* Non-zero if an objProc can be called directly. */
291	char setup; / The optional Tcl setup script. */
292	tcl_NotifyProc xPreEval; / Optional, called before Tcl_Eval(). /
293	void pPreContext; / Optional, provided to xPreEval(). */
294	tcl_NotifyProc xPostEval; / Optional, called after Tcl_Eval(). /
295	void pPostContext; / Optional, provided to xPostEval(). */
	@@ -443,20 +454,13 @@
454	int argc,
455	const char **argv,
456	int *argl
457	){
458	Tcl_Interp *tclInterp;




459	int rc = TH_OK;
460	int nResult;
461	const char *zResult;



462	USE_ARGV_TO_OBJV();
463
464	if( createTclInterp(interp, ctx)!=TH_OK ){
465	return TH_ERROR;
466	}
	@@ -472,35 +476,40 @@
476	if( rc!=TH_OK ){
477	return rc;
478	}
479	Tcl_Preserve((ClientData)tclInterp);
480	#if !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV
481	if( GET_CTX_TCL_USEOBJPROC(ctx) ){
482	Tcl_Command command;
483	Tcl_CmdInfo cmdInfo;
484	Tcl_Obj *objPtr = Tcl_NewStringObj(argv[1], argl[1]);
485	Tcl_IncrRefCount(objPtr);
486	command = Tcl_GetCommandFromObj(tclInterp, objPtr);
487	if( !command \|\| Tcl_GetCommandInfoFromToken(command, &cmdInfo)==0 ){
488	Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
489	Tcl_DecrRefCount(objPtr);
490	Tcl_Release((ClientData)tclInterp);
491	return TH_ERROR;
492	}
493	if( !cmdInfo.objProc ){
494	Th_ErrorMessage(interp, "cannot invoke Tcl command:", argv[1], argl[1]);
495	Tcl_DecrRefCount(objPtr);
496	Tcl_Release((ClientData)tclInterp);
497	return TH_ERROR;
498	}
499	Tcl_DecrRefCount(objPtr);
500	COPY_ARGV_TO_OBJV();
501	Tcl_ResetResult(tclInterp);
502	rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
503	FREE_ARGV_TO_OBJV();
504	}else
505	#endif /* !defined(USE_TCL_EVALOBJV) \|\| !USE_TCL_EVALOBJV */
506	{
507	COPY_ARGV_TO_OBJV();
508	rc = Tcl_EvalObjv(tclInterp, objc, objv, 0);
509	FREE_ARGV_TO_OBJV();
510	}
511	zResult = getTclResult(tclInterp, &nResult);
512	Th_SetResult(interp, zResult, nResult);
513	Tcl_Release((ClientData)tclInterp);
514	rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
515	return rc;
	@@ -586,11 +595,11 @@
595	};
596
597	/*
598	** Called if the Tcl interpreter is deleted. Removes the Tcl integration
599	** commands from the TH1 interpreter.
600	*/
601	static void Th1DeleteProc(
602	ClientData clientData,
603	Tcl_Interp *interp
604	){
605	int i;
	@@ -607,23 +616,25 @@
616	** When Tcl stubs support is enabled, attempts to dynamically load the Tcl
617	** shared library and fetch the function pointers necessary to create an
618	** interpreter and initialize the stubs mechanism; otherwise, simply setup
619	** the function pointers provided by the caller with the statically linked
620	** functions.
621	*/
622	static int loadTcl(
623	Th_Interp *interp,
624	void **pLibrary,
625	tcl_FindExecutableProc **pxFindExecutable,
626	tcl_CreateInterpProc **pxCreateInterp,
627	tcl_DeleteInterpProc **pxDeleteInterp,
628	tcl_FinalizeProc **pxFinalize
629	){
630	#if defined(USE_TCL_STUBS)
631	char fileName[] = TCL_LIBRARY_NAME;
632	#endif /* defined(USE_TCL_STUBS) */
633
634	if( !pLibrary \|\| !pxFindExecutable \|\| !pxCreateInterp \|\|
635	!pxDeleteInterp \|\| !pxFinalize ){
636	Th_ErrorMessage(interp,
637	"invalid Tcl loader argument(s)", (const char *)"", 0);
638	return TH_ERROR;
639	}
640	#if defined(USE_TCL_STUBS)
	@@ -631,10 +642,11 @@
642	void *library = dlopen(fileName, RTLD_NOW \| RTLD_GLOBAL);
643	if( library ){
644	tcl_FindExecutableProc *xFindExecutable;
645	tcl_CreateInterpProc *xCreateInterp;
646	tcl_DeleteInterpProc *xDeleteInterp;
647	tcl_FinalizeProc *xFinalize;
648	const char *procName = TCL_FINDEXECUTABLE_NAME;
649	xFindExecutable = (tcl_FindExecutableProc *)dlsym(library, procName + 1);
650	if( !xFindExecutable ){
651	xFindExecutable = (tcl_FindExecutableProc *)dlsym(library, procName);
652	}
	@@ -663,15 +675,27 @@
675	if( !xDeleteInterp ){
676	Th_ErrorMessage(interp,
677	"could not locate Tcl_DeleteInterp", (const char *)"", 0);
678	dlclose(library);
679	return TH_ERROR;
680	}
681	procName = TCL_FINALIZE_NAME;
682	xFinalize = (tcl_FinalizeProc *)dlsym(library, procName + 1);
683	if( !xFinalize ){
684	xFinalize = (tcl_FinalizeProc *)dlsym(library, procName);
685	}
686	if( !xFinalize ){
687	Th_ErrorMessage(interp,
688	"could not locate Tcl_Finalize", (const char *)"", 0);
689	dlclose(library);
690	return TH_ERROR;
691	}
692	*pLibrary = library;
693	*pxFindExecutable = xFindExecutable;
694	*pxCreateInterp = xCreateInterp;
695	*pxDeleteInterp = xDeleteInterp;
696	*pxFinalize = xFinalize;
697	return TH_OK;
698	}
699	} while( --fileName[TCL_MINOR_OFFSET]>'3' ); /* Tcl 8.4+ */
700	fileName[TCL_MINOR_OFFSET] = 'x';
701	Th_ErrorMessage(interp,
	@@ -681,18 +705,19 @@
705	#else
706	*pLibrary = 0;
707	*pxFindExecutable = Tcl_FindExecutable;
708	*pxCreateInterp = Tcl_CreateInterp;
709	*pxDeleteInterp = Tcl_DeleteInterp;
710	*pxFinalize = Tcl_Finalize;
711	return TH_OK;
712	#endif /* defined(USE_TCL_STUBS) */
713	}
714
715	/*
716	** Sets the "argv0", "argc", and "argv" script variables in the Tcl interpreter
717	** based on the supplied command line arguments.
718	*/
719	static int setTclArguments(
720	Tcl_Interp *pInterp,
721	int argc,
722	char **argv
723	){
	@@ -746,11 +771,11 @@
771
772	/*
773	** Creates and initializes a Tcl interpreter for use with the specified TH1
774	** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
775	** by the caller.
776	*/
777	static int createTclInterp(
778	Th_Interp *interp,
779	void *pContext
780	){
781	struct TclContext tclContext = (struct TclContext )pContext;
	@@ -767,11 +792,12 @@
792	}
793	if ( tclContext->interp ){
794	return TH_OK;
795	}
796	if( loadTcl(interp, &tclContext->library, &tclContext->xFindExecutable,
797	&tclContext->xCreateInterp, &tclContext->xDeleteInterp,
798	&tclContext->xFinalize)!=TH_OK ){
799	return TH_ERROR;
800	}
801	argc = tclContext->argc;
802	argv = tclContext->argv;
803	if( argc>0 && argv ){
	@@ -821,10 +847,15 @@
847	"Tcl error setting arguments:", Tcl_GetStringResult(tclInterp), -1);
848	Tcl_DeleteInterp(tclInterp);
849	tclContext->interp = tclInterp = 0;
850	return TH_ERROR;
851	}
852	/*
853	** Determine if an objProc can be called directly for a Tcl command invoked
854	** via the tclInvoke TH1 command.
855	*/
856	tclContext->useObjProc = canUseObjProc();
857	/* Add the TH1 integration commands to Tcl. */
858	Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
859	Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
860	Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
861	/* If necessary, evaluate the custom Tcl setup script. */
	@@ -836,10 +867,68 @@
867	tclContext->interp = tclInterp = 0;
868	return TH_ERROR;
869	}
870	return TH_OK;
871	}
872
873	/*
874	** Finalizes and unloads the previously loaded Tcl library, if applicable.
875	*/
876	int unloadTcl(
877	Th_Interp *interp,
878	void *pContext
879	){
880	struct TclContext tclContext = (struct TclContext )pContext;
881	Tcl_Interp *tclInterp;
882	tcl_FinalizeProc *xFinalize;
883	#if defined(USE_TCL_STUBS)
884	void *library;
885	#endif /* defined(USE_TCL_STUBS) */
886
887	if ( !tclContext ){
888	Th_ErrorMessage(interp,
889	"invalid Tcl context", (const char *)"", 0);
890	return TH_ERROR;
891	}
892	/*
893	** Grab the Tcl_Finalize function pointer prior to deleting the Tcl
894	** interpreter because the memory backing the Tcl stubs table will
895	** be going away.
896	*/
897	xFinalize = tclContext->xFinalize;
898	/*
899	** If the Tcl interpreter has been created, formally delete it now.
900	*/
901	tclInterp = tclContext->interp;
902	if ( tclInterp ){
903	Tcl_DeleteInterp(tclInterp);
904	tclContext->interp = tclInterp = 0;
905	}
906	/*
907	** If the Tcl library is not finalized prior to unloading it, a deadlock
908	** can occur in some circumstances (i.e. the [clock] thread is running).
909	*/
910	if( xFinalize ) xFinalize();
911	#if defined(USE_TCL_STUBS)
912	/*
913	** If Tcl is compiled on Windows using the latest MinGW, Fossil can crash
914	** when exiting while a stubs-enabled Tcl is still loaded. This is due to
915	** a bug in MinGW, see:
916	**
917	** http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724
918	**
919	** The workaround is to manually unload the loaded Tcl library prior to
920	** exiting the process.
921	*/
922	library = tclContext->library;
923	if( library ){
924	dlclose(library);
925	tclContext->library = library = 0;
926	}
927	#endif /* defined(USE_TCL_STUBS) */
928	return TH_OK;
929	}
930
931	/*
932	** Register the Tcl language commands with interpreter interp.
933	** Usually this is called soon after interpreter creation.
934	*/
935

M test/th1-tcl.test

+2 -1

		--- test/th1-tcl.test
		+++ test/th1-tcl.test
		@@ -114,11 +114,12 @@
114	114	[file nativename [file join $dir th1-tcl8.txt]]
115	115
116	116	test th1-tcl-8 {$RESULT eq {<hr><p class="thmainError">ERROR:\
117	117	cannot invoke Tcl command: tailcall</p>} \|\| $RESULT eq {<hr><p\
118	118	class="thmainError">ERROR: tailcall can only be called from a proc or\
119		-lambda</p>}}
	119	+lambda</p>} \|\| $RESULT eq {<hr><p class="thmainError">ERROR: This test\
	120	+requires Tcl 8.6 or higher.</p>}}
120	121
121	122	###############################################################################
122	123
123	124	fossil test-th-render --th-open-config \
124	125	[file nativename [file join $dir th1-tcl9.txt]]
125	126

	--- test/th1-tcl.test
	+++ test/th1-tcl.test
	@@ -114,11 +114,12 @@
114	[file nativename [file join $dir th1-tcl8.txt]]
115
116	test th1-tcl-8 {$RESULT eq {<hr><p class="thmainError">ERROR:\
117	cannot invoke Tcl command: tailcall</p>} \|\| $RESULT eq {<hr><p\
118	class="thmainError">ERROR: tailcall can only be called from a proc or\
119	lambda</p>}}

120
121	###############################################################################
122
123	fossil test-th-render --th-open-config \
124	[file nativename [file join $dir th1-tcl9.txt]]
125

	--- test/th1-tcl.test
	+++ test/th1-tcl.test
	@@ -114,11 +114,12 @@
114	[file nativename [file join $dir th1-tcl8.txt]]
115
116	test th1-tcl-8 {$RESULT eq {<hr><p class="thmainError">ERROR:\
117	cannot invoke Tcl command: tailcall</p>} \|\| $RESULT eq {<hr><p\
118	class="thmainError">ERROR: tailcall can only be called from a proc or\
119	lambda</p>} \|\| $RESULT eq {<hr><p class="thmainError">ERROR: This test\
120	requires Tcl 8.6 or higher.</p>}}
121
122	###############################################################################
123
124	fossil test-th-render --th-open-config \
125	[file nativename [file join $dir th1-tcl9.txt]]
126

M test/th1-tcl8.txt

+1 -1

		--- test/th1-tcl8.txt
		+++ test/th1-tcl8.txt
		@@ -7,8 +7,8 @@
7	7	proc doOut {msg} {puts $msg; puts \n}
8	8
9	9	if {[tclInvoke set tcl_version] >= 8.6} {
10	10	doOut [tclInvoke tailcall set x 1]
11	11	} else {
12		- doOut "This test requires Tcl 8.6 or higher."
	12	+ error "This test requires Tcl 8.6 or higher."
13	13	}
14	14	</th1>
15	15

	--- test/th1-tcl8.txt
	+++ test/th1-tcl8.txt
	@@ -7,8 +7,8 @@
7	proc doOut {msg} {puts $msg; puts \n}
8
9	if {[tclInvoke set tcl_version] >= 8.6} {
10	doOut [tclInvoke tailcall set x 1]
11	} else {
12	doOut "This test requires Tcl 8.6 or higher."
13	}
14	</th1>
15

	--- test/th1-tcl8.txt
	+++ test/th1-tcl8.txt
	@@ -7,8 +7,8 @@
7	proc doOut {msg} {puts $msg; puts \n}
8
9	if {[tclInvoke set tcl_version] >= 8.6} {
10	doOut [tclInvoke tailcall set x 1]
11	} else {
12	error "This test requires Tcl 8.6 or higher."
13	}
14	</th1>
15

M win/fossil.rc

		--- win/fossil.rc
		+++ win/fossil.rc
		@@ -103,10 +103,15 @@
103	103	#if defined(FOSSIL_ENABLE_SSL)
104	104	VALUE "SslEnabled", "Yes, " OPENSSL_VERSION_TEXT "\0"
105	105	#endif /* defined(FOSSIL_ENABLE_SSL) */
106	106	#if defined(FOSSIL_ENABLE_TCL)
107	107	VALUE "TclEnabled", "Yes, Tcl " TCL_PATCH_LEVEL "\0"
	108	+#if defined(USE_TCL_STUBS)
	109	+ VALUE "UseTclStubsEnabled", "Yes\0"
	110	+#else
	111	+ VALUE "UseTclStubsEnabled", "No\0"
	112	+#endif /* defined(USE_TCL_STUBS) */
108	113	#if defined(FOSSIL_ENABLE_TCL_STUBS)
109	114	VALUE "TclStubsEnabled", "Yes\0"
110	115	#else
111	116	VALUE "TclStubsEnabled", "No\0"
112	117	#endif /* defined(FOSSIL_ENABLE_TCL_STUBS) */
113	118

	--- win/fossil.rc
	+++ win/fossil.rc
	@@ -103,10 +103,15 @@
103	#if defined(FOSSIL_ENABLE_SSL)
104	VALUE "SslEnabled", "Yes, " OPENSSL_VERSION_TEXT "\0"
105	#endif /* defined(FOSSIL_ENABLE_SSL) */
106	#if defined(FOSSIL_ENABLE_TCL)
107	VALUE "TclEnabled", "Yes, Tcl " TCL_PATCH_LEVEL "\0"





108	#if defined(FOSSIL_ENABLE_TCL_STUBS)
109	VALUE "TclStubsEnabled", "Yes\0"
110	#else
111	VALUE "TclStubsEnabled", "No\0"
112	#endif /* defined(FOSSIL_ENABLE_TCL_STUBS) */
113

	--- win/fossil.rc
	+++ win/fossil.rc
	@@ -103,10 +103,15 @@
103	#if defined(FOSSIL_ENABLE_SSL)
104	VALUE "SslEnabled", "Yes, " OPENSSL_VERSION_TEXT "\0"
105	#endif /* defined(FOSSIL_ENABLE_SSL) */
106	#if defined(FOSSIL_ENABLE_TCL)
107	VALUE "TclEnabled", "Yes, Tcl " TCL_PATCH_LEVEL "\0"
108	#if defined(USE_TCL_STUBS)
109	VALUE "UseTclStubsEnabled", "Yes\0"
110	#else
111	VALUE "UseTclStubsEnabled", "No\0"
112	#endif /* defined(USE_TCL_STUBS) */
113	#if defined(FOSSIL_ENABLE_TCL_STUBS)
114	VALUE "TclStubsEnabled", "Yes\0"
115	#else
116	VALUE "TclStubsEnabled", "No\0"
117	#endif /* defined(FOSSIL_ENABLE_TCL_STUBS) */
118

Fossil SCM

Keyboard Shortcuts