fa4e828653c… — Fossil SCM

M src/configure.c

+2

		--- src/configure.c
		+++ src/configure.c
		@@ -89,12 +89,14 @@
89	89	{ "timeline-block-markup", CONFIGSET_SKIN },
90	90	{ "timeline-max-comment", CONFIGSET_SKIN },
91	91	{ "adunit", CONFIGSET_SKIN },
92	92	{ "adunit-omit-if-admin", CONFIGSET_SKIN },
93	93	{ "adunit-omit-if-user", CONFIGSET_SKIN },
	94	+
94	95	#ifdef FOSSIL_ENABLE_TCL
95	96	{ "tcl", CONFIGSET_SKIN\|CONFIGSET_TKT\|CONFIGSET_XFER },
	97	+ { "tcl-setup", CONFIGSET_SKIN\|CONFIGSET_TKT\|CONFIGSET_XFER },
96	98	#endif
97	99
98	100	{ "project-name", CONFIGSET_PROJ },
99	101	{ "project-description", CONFIGSET_PROJ },
100	102	{ "manifest", CONFIGSET_PROJ },
101	103

	--- src/configure.c
	+++ src/configure.c
	@@ -89,12 +89,14 @@
89	{ "timeline-block-markup", CONFIGSET_SKIN },
90	{ "timeline-max-comment", CONFIGSET_SKIN },
91	{ "adunit", CONFIGSET_SKIN },
92	{ "adunit-omit-if-admin", CONFIGSET_SKIN },
93	{ "adunit-omit-if-user", CONFIGSET_SKIN },

94	#ifdef FOSSIL_ENABLE_TCL
95	{ "tcl", CONFIGSET_SKIN\|CONFIGSET_TKT\|CONFIGSET_XFER },

96	#endif
97
98	{ "project-name", CONFIGSET_PROJ },
99	{ "project-description", CONFIGSET_PROJ },
100	{ "manifest", CONFIGSET_PROJ },
101

	--- src/configure.c
	+++ src/configure.c
	@@ -89,12 +89,14 @@
89	{ "timeline-block-markup", CONFIGSET_SKIN },
90	{ "timeline-max-comment", CONFIGSET_SKIN },
91	{ "adunit", CONFIGSET_SKIN },
92	{ "adunit-omit-if-admin", CONFIGSET_SKIN },
93	{ "adunit-omit-if-user", CONFIGSET_SKIN },
94
95	#ifdef FOSSIL_ENABLE_TCL
96	{ "tcl", CONFIGSET_SKIN\|CONFIGSET_TKT\|CONFIGSET_XFER },
97	{ "tcl-setup", CONFIGSET_SKIN\|CONFIGSET_TKT\|CONFIGSET_XFER },
98	#endif
99
100	{ "project-name", CONFIGSET_PROJ },
101	{ "project-description", CONFIGSET_PROJ },
102	{ "manifest", CONFIGSET_PROJ },
103

M src/db.c

+11 -5

		--- src/db.c
		+++ src/db.c
		@@ -2039,10 +2039,11 @@
2039	2039	{ "ssl-ca-location",0, 40, 0, "" },
2040	2040	{ "ssl-identity", 0, 40, 0, "" },
2041	2041	{ "ssh-command", 0, 32, 0, "" },
2042	2042	#ifdef FOSSIL_ENABLE_TCL
2043	2043	{ "tcl", 0, 0, 0, "off" },
	2044	+ { "tcl-setup", 0, 40, 0, "" },
2044	2045	#endif
2045	2046	{ "web-browser", 0, 32, 0, "" },
2046	2047	{ "white-foreground", 0, 0, 0, "off" },
2047	2048	{ 0,0,0,0,0 }
2048	2049	};
		@@ -2203,15 +2204,20 @@
2203	2204	** password authentication.
2204	2205	**
2205	2206	** ssh-command Command used to talk to a remote machine with
2206	2207	** the "ssh://" protocol.
2207	2208	**
2208		-** tcl If enabled, Tcl integration commands will be added to
2209		-** the TH1 interpreter, allowing Tcl expressions and
2210		-** scripts to be evaluated from TH1. Additionally, the
2211		-** Tcl interpreter will be able to evaluate TH1 expressions
2212		-** and scripts. Default: off.
	2209	+** tcl If enabled (and Fossil was compiled with Tcl support),
	2210	+** Tcl integration commands will be added to the TH1
	2211	+** interpreter, allowing arbitrary Tcl expressions and
	2212	+** scripts to be evaluated from TH1. Additionally, the Tcl
	2213	+** interpreter will be able to evaluate arbitrary TH1
	2214	+** expressions and scripts. Default: off.
	2215	+**
	2216	+** tcl-setup This is the setup script to be evaluated after creating
	2217	+** and initializing the Tcl interpreter. By default, this
	2218	+** is empty and no extra setup is performed.
2213	2219	**
2214	2220	** web-browser A shell command used to launch your preferred
2215	2221	** web browser when given a URL as an argument.
2216	2222	** Defaults to "start" on windows, "open" on Mac,
2217	2223	** and "firefox" on Unix.
2218	2224

	--- src/db.c
	+++ src/db.c
	@@ -2039,10 +2039,11 @@
2039	{ "ssl-ca-location",0, 40, 0, "" },
2040	{ "ssl-identity", 0, 40, 0, "" },
2041	{ "ssh-command", 0, 32, 0, "" },
2042	#ifdef FOSSIL_ENABLE_TCL
2043	{ "tcl", 0, 0, 0, "off" },

2044	#endif
2045	{ "web-browser", 0, 32, 0, "" },
2046	{ "white-foreground", 0, 0, 0, "off" },
2047	{ 0,0,0,0,0 }
2048	};
	@@ -2203,15 +2204,20 @@
2203	** password authentication.
2204	**
2205	** ssh-command Command used to talk to a remote machine with
2206	** the "ssh://" protocol.
2207	**
2208	** tcl If enabled, Tcl integration commands will be added to
2209	** the TH1 interpreter, allowing Tcl expressions and
2210	** scripts to be evaluated from TH1. Additionally, the
2211	** Tcl interpreter will be able to evaluate TH1 expressions
2212	** and scripts. Default: off.





2213	**
2214	** web-browser A shell command used to launch your preferred
2215	** web browser when given a URL as an argument.
2216	** Defaults to "start" on windows, "open" on Mac,
2217	** and "firefox" on Unix.
2218

	--- src/db.c
	+++ src/db.c
	@@ -2039,10 +2039,11 @@
2039	{ "ssl-ca-location",0, 40, 0, "" },
2040	{ "ssl-identity", 0, 40, 0, "" },
2041	{ "ssh-command", 0, 32, 0, "" },
2042	#ifdef FOSSIL_ENABLE_TCL
2043	{ "tcl", 0, 0, 0, "off" },
2044	{ "tcl-setup", 0, 40, 0, "" },
2045	#endif
2046	{ "web-browser", 0, 32, 0, "" },
2047	{ "white-foreground", 0, 0, 0, "off" },
2048	{ 0,0,0,0,0 }
2049	};
	@@ -2203,15 +2204,20 @@
2204	** password authentication.
2205	**
2206	** ssh-command Command used to talk to a remote machine with
2207	** the "ssh://" protocol.
2208	**
2209	** tcl If enabled (and Fossil was compiled with Tcl support),
2210	** Tcl integration commands will be added to the TH1
2211	** interpreter, allowing arbitrary Tcl expressions and
2212	** scripts to be evaluated from TH1. Additionally, the Tcl
2213	** interpreter will be able to evaluate arbitrary TH1
2214	** expressions and scripts. Default: off.
2215	**
2216	** tcl-setup This is the setup script to be evaluated after creating
2217	** and initializing the Tcl interpreter. By default, this
2218	** is empty and no extra setup is performed.
2219	**
2220	** web-browser A shell command used to launch your preferred
2221	** web browser when given a URL as an argument.
2222	** Defaults to "start" on windows, "open" on Mac,
2223	** and "firefox" on Unix.
2224

M src/main.c

+23 -8

		--- src/main.c
		+++ src/main.c
		@@ -88,16 +88,17 @@
88	88	** All Tcl related context information is in this structure. This structure
89	89	** definition has been copied from and should be kept in sync with the one in
90	90	** "th_tcl.c".
91	91	*/
92	92	struct TclContext {
93		- int argc;
94		- char **argv;
95		- void *library;
96		- void xFindExecutable; / see tcl_FindExecutableProc in th_tcl.c */
97		- void xCreateInterp; / see tcl_CreateInterpProc in th_tcl.c */
98		- Tcl_Interp *interp;
	93	+ int argc; /* Number of original (expanded) arguments. */
	94	+ char *argv; / Full copy of the original (expanded) arguments. */
	95	+ void library; / The Tcl library module handle. */
	96	+ void xFindExecutable; / See tcl_FindExecutableProc in th_tcl.c. */
	97	+ void xCreateInterp; / See tcl_CreateInterpProc in th_tcl.c. */
	98	+ Tcl_Interp interp; / The on-demand created Tcl interpreter. */
	99	+ char setup; / The optional Tcl setup script. */
99	100	};
100	101	#endif
101	102
102	103	/*
103	104	** All global variables are in this structure.
		@@ -549,10 +550,24 @@
549	550	while( i<g.argc ) newArgv[j++] = g.argv[i++];
550	551	newArgv[j] = 0;
551	552	g.argc = j;
552	553	g.argv = newArgv;
553	554	}
	555	+
	556	+/*
	557	+** Make a deep copy of the provided argument array and return it.
	558	+*/
	559	+static char copy_args(int argc, char argv){
	560	+ char **zNewArgv;
	561	+ int i;
	562	+ zNewArgv = fossil_malloc( sizeof(char)(argc+1) );
	563	+ memset(zNewArgv, 0, sizeof(char)(argc+1));
	564	+ for(i=0; i<argc; i++){
	565	+ zNewArgv[i] = fossil_strdup(argv[i]);
	566	+ }
	567	+ return zNewArgv;
	568	+}
554	569
555	570	/*
556	571	** This procedure runs first.
557	572	*/
558	573	int main(int argc, char **argv)
		@@ -577,13 +592,13 @@
577	592	g.json.outOpt.addNewline = 1;
578	593	g.json.outOpt.indentation = 1 /* in CGI/server mode this can be configured */;
579	594	#endif /* FOSSIL_ENABLE_JSON */
580	595	expand_args_option(argc, argv);
581	596	#ifdef FOSSIL_ENABLE_TCL
	597	+ memset(&g.tcl, 0, sizeof(TclContext));
582	598	g.tcl.argc = g.argc;
583		- g.tcl.argv = g.argv;
584		- g.tcl.interp = 0;
	599	+ g.tcl.argv = copy_args(g.argc, g.argv); /* save full arguments */
585	600	#endif
586	601	if( fossil_getenv("GATEWAY_INTERFACE")!=0 && !find_option("nocgi", 0, 0)){
587	602	zCmdName = "cgi";
588	603	g.isHTTP = 1;
589	604	}else if( g.argc<2 ){
590	605

	--- src/main.c
	+++ src/main.c
	@@ -88,16 +88,17 @@
88	** All Tcl related context information is in this structure. This structure
89	** definition has been copied from and should be kept in sync with the one in
90	** "th_tcl.c".
91	*/
92	struct TclContext {
93	int argc;
94	char **argv;
95	void *library;
96	void xFindExecutable; / see tcl_FindExecutableProc in th_tcl.c */
97	void xCreateInterp; / see tcl_CreateInterpProc in th_tcl.c */
98	Tcl_Interp *interp;

99	};
100	#endif
101
102	/*
103	** All global variables are in this structure.
	@@ -549,10 +550,24 @@
549	while( i<g.argc ) newArgv[j++] = g.argv[i++];
550	newArgv[j] = 0;
551	g.argc = j;
552	g.argv = newArgv;
553	}














554
555	/*
556	** This procedure runs first.
557	*/
558	int main(int argc, char **argv)
	@@ -577,13 +592,13 @@
577	g.json.outOpt.addNewline = 1;
578	g.json.outOpt.indentation = 1 /* in CGI/server mode this can be configured */;
579	#endif /* FOSSIL_ENABLE_JSON */
580	expand_args_option(argc, argv);
581	#ifdef FOSSIL_ENABLE_TCL

582	g.tcl.argc = g.argc;
583	g.tcl.argv = g.argv;
584	g.tcl.interp = 0;
585	#endif
586	if( fossil_getenv("GATEWAY_INTERFACE")!=0 && !find_option("nocgi", 0, 0)){
587	zCmdName = "cgi";
588	g.isHTTP = 1;
589	}else if( g.argc<2 ){
590

	--- src/main.c
	+++ src/main.c
	@@ -88,16 +88,17 @@
88	** All Tcl related context information is in this structure. This structure
89	** definition has been copied from and should be kept in sync with the one in
90	** "th_tcl.c".
91	*/
92	struct TclContext {
93	int argc; /* Number of original (expanded) arguments. */
94	char *argv; / Full copy of the original (expanded) arguments. */
95	void library; / The Tcl library module handle. */
96	void xFindExecutable; / See tcl_FindExecutableProc in th_tcl.c. */
97	void xCreateInterp; / See tcl_CreateInterpProc in th_tcl.c. */
98	Tcl_Interp interp; / The on-demand created Tcl interpreter. */
99	char setup; / The optional Tcl setup script. */
100	};
101	#endif
102
103	/*
104	** All global variables are in this structure.
	@@ -549,10 +550,24 @@
550	while( i<g.argc ) newArgv[j++] = g.argv[i++];
551	newArgv[j] = 0;
552	g.argc = j;
553	g.argv = newArgv;
554	}
555
556	/*
557	** Make a deep copy of the provided argument array and return it.
558	*/
559	static char copy_args(int argc, char argv){
560	char **zNewArgv;
561	int i;
562	zNewArgv = fossil_malloc( sizeof(char)(argc+1) );
563	memset(zNewArgv, 0, sizeof(char)(argc+1));
564	for(i=0; i<argc; i++){
565	zNewArgv[i] = fossil_strdup(argv[i]);
566	}
567	return zNewArgv;
568	}
569
570	/*
571	** This procedure runs first.
572	*/
573	int main(int argc, char **argv)
	@@ -577,13 +592,13 @@
592	g.json.outOpt.addNewline = 1;
593	g.json.outOpt.indentation = 1 /* in CGI/server mode this can be configured */;
594	#endif /* FOSSIL_ENABLE_JSON */
595	expand_args_option(argc, argv);
596	#ifdef FOSSIL_ENABLE_TCL
597	memset(&g.tcl, 0, sizeof(TclContext));
598	g.tcl.argc = g.argc;
599	g.tcl.argv = copy_args(g.argc, g.argv); /* save full arguments */

600	#endif
601	if( fossil_getenv("GATEWAY_INTERFACE")!=0 && !find_option("nocgi", 0, 0)){
602	zCmdName = "cgi";
603	g.isHTTP = 1;
604	}else if( g.argc<2 ){
605

M src/th_main.c

+10 -3

		--- src/th_main.c
		+++ src/th_main.c
		@@ -221,13 +221,14 @@
221	221	** TH command: hasfeature STRING
222	222	**
223	223	** Return true if the fossil binary has the given compile-time feature
224	224	** enabled. The set of features includes:
225	225	**
226		-** "json" = FOSSIL_ENABLE_JSON
227		-** "tcl" = FOSSIL_ENABLE_TCL
228		-** "ssl" = FOSSIL_ENABLE_SSL
	226	+** "json" = FOSSIL_ENABLE_JSON
	227	+** "ssl" = FOSSIL_ENABLE_SSL
	228	+** "tcl" = FOSSIL_ENABLE_TCL
	229	+** "tclStubs" = FOSSIL_ENABLE_TCL_STUBS
229	230	**
230	231	*/
231	232	static int hasfeatureCmd(
232	233	Th_Interp *interp,
233	234	void *p,
		@@ -256,10 +257,15 @@
256	257	#endif
257	258	#if defined(FOSSIL_ENABLE_TCL)
258	259	else if( 0 == fossil_strnicmp( zArg, "tcl", 3 ) ){
259	260	rc = 1;
260	261	}
	262	+#endif
	263	+#if defined(FOSSIL_ENABLE_TCL_STUBS)
	264	+ else if( 0 == fossil_strnicmp( zArg, "tclStubs", 8 ) ){
	265	+ rc = 1;
	266	+ }
261	267	#endif
262	268	if( g.thTrace ){
263	269	Th_Trace("[hasfeature %#h] => %d<br />\n", argl[1], zArg, rc);
264	270	}
265	271	Th_SetResultInt(interp, rc);
		@@ -447,10 +453,11 @@
447	453	int i;
448	454	g.interp = Th_CreateInterp(&vtab);
449	455	th_register_language(g.interp); /* Basic scripting commands. */
450	456	#ifdef FOSSIL_ENABLE_TCL
451	457	if( getenv("TH1_ENABLE_TCL")!=0 \|\| db_get_boolean("tcl", 0) ){
	458	+ g.tcl.setup = db_get("tcl-setup", 0); /* Grab optional setup script. */
452	459	th_register_tcl(g.interp, &g.tcl); /* Tcl integration commands. */
453	460	}
454	461	#endif
455	462	for(i=0; i<sizeof(aCommand)/sizeof(aCommand[0]); i++){
456	463	if ( !aCommand[i].zName \|\| !aCommand[i].xProc ) continue;
457	464

	--- src/th_main.c
	+++ src/th_main.c
	@@ -221,13 +221,14 @@
221	** TH command: hasfeature STRING
222	**
223	** Return true if the fossil binary has the given compile-time feature
224	** enabled. The set of features includes:
225	**
226	** "json" = FOSSIL_ENABLE_JSON
227	** "tcl" = FOSSIL_ENABLE_TCL
228	** "ssl" = FOSSIL_ENABLE_SSL

229	**
230	*/
231	static int hasfeatureCmd(
232	Th_Interp *interp,
233	void *p,
	@@ -256,10 +257,15 @@
256	#endif
257	#if defined(FOSSIL_ENABLE_TCL)
258	else if( 0 == fossil_strnicmp( zArg, "tcl", 3 ) ){
259	rc = 1;
260	}





261	#endif
262	if( g.thTrace ){
263	Th_Trace("[hasfeature %#h] => %d<br />\n", argl[1], zArg, rc);
264	}
265	Th_SetResultInt(interp, rc);
	@@ -447,10 +453,11 @@
447	int i;
448	g.interp = Th_CreateInterp(&vtab);
449	th_register_language(g.interp); /* Basic scripting commands. */
450	#ifdef FOSSIL_ENABLE_TCL
451	if( getenv("TH1_ENABLE_TCL")!=0 \|\| db_get_boolean("tcl", 0) ){

452	th_register_tcl(g.interp, &g.tcl); /* Tcl integration commands. */
453	}
454	#endif
455	for(i=0; i<sizeof(aCommand)/sizeof(aCommand[0]); i++){
456	if ( !aCommand[i].zName \|\| !aCommand[i].xProc ) continue;
457

	--- src/th_main.c
	+++ src/th_main.c
	@@ -221,13 +221,14 @@
221	** TH command: hasfeature STRING
222	**
223	** Return true if the fossil binary has the given compile-time feature
224	** enabled. The set of features includes:
225	**
226	** "json" = FOSSIL_ENABLE_JSON
227	** "ssl" = FOSSIL_ENABLE_SSL
228	** "tcl" = FOSSIL_ENABLE_TCL
229	** "tclStubs" = FOSSIL_ENABLE_TCL_STUBS
230	**
231	*/
232	static int hasfeatureCmd(
233	Th_Interp *interp,
234	void *p,
	@@ -256,10 +257,15 @@
257	#endif
258	#if defined(FOSSIL_ENABLE_TCL)
259	else if( 0 == fossil_strnicmp( zArg, "tcl", 3 ) ){
260	rc = 1;
261	}
262	#endif
263	#if defined(FOSSIL_ENABLE_TCL_STUBS)
264	else if( 0 == fossil_strnicmp( zArg, "tclStubs", 8 ) ){
265	rc = 1;
266	}
267	#endif
268	if( g.thTrace ){
269	Th_Trace("[hasfeature %#h] => %d<br />\n", argl[1], zArg, rc);
270	}
271	Th_SetResultInt(interp, rc);
	@@ -447,10 +453,11 @@
453	int i;
454	g.interp = Th_CreateInterp(&vtab);
455	th_register_language(g.interp); /* Basic scripting commands. */
456	#ifdef FOSSIL_ENABLE_TCL
457	if( getenv("TH1_ENABLE_TCL")!=0 \|\| db_get_boolean("tcl", 0) ){
458	g.tcl.setup = db_get("tcl-setup", 0); /* Grab optional setup script. */
459	th_register_tcl(g.interp, &g.tcl); /* Tcl integration commands. */
460	}
461	#endif
462	for(i=0; i<sizeof(aCommand)/sizeof(aCommand[0]); i++){
463	if ( !aCommand[i].zName \|\| !aCommand[i].xProc ) continue;
464

M src/th_tcl.c

+17 -6

		--- src/th_tcl.c
		+++ src/th_tcl.c
		@@ -166,16 +166,17 @@
166	166	/*
167	167	** Tcl context information used by TH1. This structure definition has been
168	168	** copied from and should be kept in sync with the one in "main.c".
169	169	*/
170	170	struct TclContext {
171		- int argc;
172		- char **argv;
173		- void *library;
174		- tcl_FindExecutableProc *xFindExecutable;
175		- tcl_CreateInterpProc *xCreateInterp;
176		- Tcl_Interp *interp;
	171	+ int argc; /* Number of original arguments. */
	172	+ char *argv; / Full copy of the original arguments. */
	173	+ void library; / The Tcl library module handle. */
	174	+ tcl_FindExecutableProc xFindExecutable; / Tcl_FindExecutable() pointer. */
	175	+ tcl_CreateInterpProc xCreateInterp; / Tcl_CreateInterp() pointer. */
	176	+ Tcl_Interp interp; / The on-demand created Tcl interpreter. */
	177	+ char setup; / The optional Tcl setup script. */
177	178	};
178	179
179	180	/*
180	181	** Syntax:
181	182	**
		@@ -582,10 +583,11 @@
582	583	struct TclContext tclContext = (struct TclContext )pContext;
583	584	int argc;
584	585	char **argv;
585	586	char *argv0 = 0;
586	587	Tcl_Interp *tclInterp;
	588	+ char *setup;
587	589
588	590	if ( !tclContext ){
589	591	Th_ErrorMessage(interp,
590	592	"Invalid Tcl context", (const char *)"", 0);
591	593	return TH_ERROR;
		@@ -630,10 +632,19 @@
630	632	}
631	633	/* Add the TH1 integration commands to Tcl. */
632	634	Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
633	635	Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
634	636	Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
	637	+ /* If necessary, evaluate the custom Tcl setup script. */
	638	+ setup = tclContext->setup;
	639	+ if( setup && Tcl_Eval(tclInterp, setup)!=TCL_OK ){
	640	+ Th_ErrorMessage(interp,
	641	+ "Tcl setup script error:", Tcl_GetStringResult(tclInterp), -1);
	642	+ Tcl_DeleteInterp(tclInterp);
	643	+ tclContext->interp = tclInterp = 0;
	644	+ return TH_ERROR;
	645	+ }
635	646	return TH_OK;
636	647	}
637	648
638	649	/*
639	650	** Register the Tcl language commands with interpreter interp.
640	651

	--- src/th_tcl.c
	+++ src/th_tcl.c
	@@ -166,16 +166,17 @@
166	/*
167	** Tcl context information used by TH1. This structure definition has been
168	** copied from and should be kept in sync with the one in "main.c".
169	*/
170	struct TclContext {
171	int argc;
172	char **argv;
173	void *library;
174	tcl_FindExecutableProc *xFindExecutable;
175	tcl_CreateInterpProc *xCreateInterp;
176	Tcl_Interp *interp;

177	};
178
179	/*
180	** Syntax:
181	**
	@@ -582,10 +583,11 @@
582	struct TclContext tclContext = (struct TclContext )pContext;
583	int argc;
584	char **argv;
585	char *argv0 = 0;
586	Tcl_Interp *tclInterp;

587
588	if ( !tclContext ){
589	Th_ErrorMessage(interp,
590	"Invalid Tcl context", (const char *)"", 0);
591	return TH_ERROR;
	@@ -630,10 +632,19 @@
630	}
631	/* Add the TH1 integration commands to Tcl. */
632	Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
633	Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
634	Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);









635	return TH_OK;
636	}
637
638	/*
639	** Register the Tcl language commands with interpreter interp.
640

	--- src/th_tcl.c
	+++ src/th_tcl.c
	@@ -166,16 +166,17 @@
166	/*
167	** Tcl context information used by TH1. This structure definition has been
168	** copied from and should be kept in sync with the one in "main.c".
169	*/
170	struct TclContext {
171	int argc; /* Number of original arguments. */
172	char *argv; / Full copy of the original arguments. */
173	void library; / The Tcl library module handle. */
174	tcl_FindExecutableProc xFindExecutable; / Tcl_FindExecutable() pointer. */
175	tcl_CreateInterpProc xCreateInterp; / Tcl_CreateInterp() pointer. */
176	Tcl_Interp interp; / The on-demand created Tcl interpreter. */
177	char setup; / The optional Tcl setup script. */
178	};
179
180	/*
181	** Syntax:
182	**
	@@ -582,10 +583,11 @@
583	struct TclContext tclContext = (struct TclContext )pContext;
584	int argc;
585	char **argv;
586	char *argv0 = 0;
587	Tcl_Interp *tclInterp;
588	char *setup;
589
590	if ( !tclContext ){
591	Th_ErrorMessage(interp,
592	"Invalid Tcl context", (const char *)"", 0);
593	return TH_ERROR;
	@@ -630,10 +632,19 @@
632	}
633	/* Add the TH1 integration commands to Tcl. */
634	Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
635	Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
636	Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
637	/* If necessary, evaluate the custom Tcl setup script. */
638	setup = tclContext->setup;
639	if( setup && Tcl_Eval(tclInterp, setup)!=TCL_OK ){
640	Th_ErrorMessage(interp,
641	"Tcl setup script error:", Tcl_GetStringResult(tclInterp), -1);
642	Tcl_DeleteInterp(tclInterp);
643	tclContext->interp = tclInterp = 0;
644	return TH_ERROR;
645	}
646	return TH_OK;
647	}
648
649	/*
650	** Register the Tcl language commands with interpreter interp.
651

Fossil SCM

Keyboard Shortcuts