Fossil SCM

Minor enhancements to the Tcl integration subsystem.

mistachkin 2014-09-05 06:23 trunk
Commit 946c3eb6400263c6b407fa735368a67fd3656733
Parent 2212ac40a8d4e2f…
3 files changed +1 -1 +1 -1 +37 -3
~ src/diffcmd.c ~ src/th.h ~ src/th_tcl.c
M src/diffcmd.c
+1 -1
--- src/diffcmd.c
+++ src/diffcmd.c
@@ -1036,11 +1036,11 @@
10361036
 fossil_print("To see diff, run: tclsh \"%s\"\n", zTempFile);
10371037
 }else{
10381038
 #if defined(FOSSIL_ENABLE_TCL)
10391039
 Th_FossilInit(TH_INIT_DEFAULT);
10401040
 if( evaluateTclWithEvents(g.interp, &g.tcl, blob_str(&script),
1041
- blob_size(&script), 1)==TCL_OK ){
1041
+ blob_size(&script), 1, 0)==TCL_OK ){
10421042
 blob_reset(&script);
10431043
 return;
10441044
 }
10451045
 /*
10461046
 * If evaluation of the Tcl script fails, the reason may be that Tk
10471047
--- src/diffcmd.c
+++ src/diffcmd.c
@@ -1036,11 +1036,11 @@
1036 fossil_print("To see diff, run: tclsh \"%s\"\n", zTempFile);
1037 }else{
1038 #if defined(FOSSIL_ENABLE_TCL)
1039 Th_FossilInit(TH_INIT_DEFAULT);
1040 if( evaluateTclWithEvents(g.interp, &g.tcl, blob_str(&script),
1041 blob_size(&script), 1)==TCL_OK ){
1042 blob_reset(&script);
1043 return;
1044 }
1045 /*
1046 * If evaluation of the Tcl script fails, the reason may be that Tk
1047
--- src/diffcmd.c
+++ src/diffcmd.c
@@ -1036,11 +1036,11 @@
1036 fossil_print("To see diff, run: tclsh \"%s\"\n", zTempFile);
1037 }else{
1038 #if defined(FOSSIL_ENABLE_TCL)
1039 Th_FossilInit(TH_INIT_DEFAULT);
1040 if( evaluateTclWithEvents(g.interp, &g.tcl, blob_str(&script),
1041 blob_size(&script), 1, 0)==TCL_OK ){
1042 blob_reset(&script);
1043 return;
1044 }
1045 /*
1046 * If evaluation of the Tcl script fails, the reason may be that Tk
1047
M src/th.h
+1 -1
--- src/th.h
+++ src/th.h
@@ -166,11 +166,11 @@
166166
 /*
167167
 ** Interfaces to the full Tcl core library from "th_tcl.c".
168168
 */
169169
 int th_register_tcl(Th_Interp *, void *);
170170
 int unloadTcl(Th_Interp *, void *);
171
-int evaluateTclWithEvents(Th_Interp *, void *, const char *, int, int);
171
+int evaluateTclWithEvents(Th_Interp *, void *, const char *, int, int, int);
172172
 #endif
173173
174174
 /*
175175
 ** General purpose hash table from th_lang.c.
176176
 */
177177
--- src/th.h
+++ src/th.h
@@ -166,11 +166,11 @@
166 /*
167 ** Interfaces to the full Tcl core library from "th_tcl.c".
168 */
169 int th_register_tcl(Th_Interp *, void *);
170 int unloadTcl(Th_Interp *, void *);
171 int evaluateTclWithEvents(Th_Interp *, void *, const char *, int, int);
172 #endif
173
174 /*
175 ** General purpose hash table from th_lang.c.
176 */
177
--- src/th.h
+++ src/th.h
@@ -166,11 +166,11 @@
166 /*
167 ** Interfaces to the full Tcl core library from "th_tcl.c".
168 */
169 int th_register_tcl(Th_Interp *, void *);
170 int unloadTcl(Th_Interp *, void *);
171 int evaluateTclWithEvents(Th_Interp *, void *, const char *, int, int, int);
172 #endif
173
174 /*
175 ** General purpose hash table from th_lang.c.
176 */
177
M src/th_tcl.c
+37 -3
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -20,10 +20,11 @@
2020
 */
2121
 #include "config.h"
2222
2323
 #ifdef FOSSIL_ENABLE_TCL
2424
25
+#include "sqlite3.h"
2526
 #include "th.h"
2627
 #include "tcl.h"
2728
2829
 /*
2930
 ** These macros are designed to reduce the redundant code required to marshal
@@ -165,11 +166,12 @@
165166
 /*
166167
 ** HACK: Using some preprocessor magic and a private static variable, redirect
167168
 ** the Tcl API calls [found within this file] to the function pointers
168169
 ** that will be contained in our private Tcl stubs table. This takes
169170
 ** advantage of the fact that the Tcl headers always define the Tcl API
170
-** functions in terms of the "tclStubsPtr" variable.
171
+** functions in terms of the "tclStubsPtr" variable when the define
172
+** USE_TCL_STUBS is present during compilation.
171173
 */
172174
 #define tclStubsPtr privateTclStubsPtr
173175
 static const TclStubs *tclStubsPtr = NULL;
174176
175177
 /*
@@ -248,10 +250,32 @@
248250
 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
249251
 ** by the caller. This must be declared here because quite a few functions in
250252
 ** this file need to use it before it can be defined.
251253
 */
252254
 static int createTclInterp(Th_Interp *interp, void *pContext);
255
+
256
+/*
257
+** Returns a name for a Tcl return code.
258
+*/
259
+static const char *getTclReturnCodeName(
260
+ int rc,
261
+ int nullIfOk
262
+){
263
+ static char zRc[32];
264
+
265
+ switch( rc ){
266
+ case TCL_OK: return nullIfOk ? 0 : "TCL_OK";
267
+ case TCL_ERROR: return "TCL_ERROR";
268
+ case TCL_BREAK: return "TCL_BREAK";
269
+ case TCL_RETURN: return "TCL_RETURN";
270
+ case TCL_CONTINUE: return "TCL_CONTINUE";
271
+ default: {
272
+ sqlite3_snprintf(sizeof(zRc), zRc, "Tcl return code %d", rc);
273
+ }
274
+ }
275
+ return zRc;
276
+}
253277
254278
 /*
255279
 ** Returns the Tcl interpreter result as a string with the associated length.
256280
 ** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
257281
 ** If the length pointer is NULL, the length will not be stored.
@@ -774,16 +798,19 @@
774798
 ** Tcl script succeeds, start a Tcl event loop until there are no more events
775799
 ** remaining to process -OR- the script calls [exit]. If the bWait argument
776800
 ** is zero, only process events that are already in the queue; otherwise,
777801
 ** process events until the script terminates the Tcl event loop.
778802
 */
803
+void fossil_print(const char *zFormat, ...); /* printf.h */
804
+
779805
 int evaluateTclWithEvents(
780806
 Th_Interp *interp,
781807
 void *pContext,
782808
 const char *zScript,
783809
 int nScript,
784
- int bWait
810
+ int bWait,
811
+ int bVerbose
785812
 ){
786813
 struct TclContext *tclContext = (struct TclContext *)pContext;
787814
 Tcl_Interp *tclInterp;
788815
 int rc;
789816
 int flags = TCL_ALL_EVENTS;
@@ -791,11 +818,18 @@
791818
 if( createTclInterp(interp, pContext)!=TH_OK ){
792819
 return TH_ERROR;
793820
 }
794821
 tclInterp = tclContext->interp;
795822
 rc = Tcl_EvalEx(tclInterp, zScript, nScript, TCL_EVAL_GLOBAL);
796
- if( rc!=TCL_OK ) return rc;
823
+ if( rc!=TCL_OK ){
824
+ if( bVerbose ){
825
+ const char *zResult = getTclResult(tclInterp, 0);
826
+ fossil_print("%s: ", getTclReturnCodeName(rc, 0));
827
+ fossil_print("%s\n", zResult);
828
+ }
829
+ return rc;
830
+ }
797831
 if( !bWait ) flags |= TCL_DONT_WAIT;
798832
 while( Tcl_DoOneEvent(flags) ){
799833
 /* do nothing */
800834
 }
801835
 return rc;
802836
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -20,10 +20,11 @@
20 */
21 #include "config.h"
22
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
@@ -165,11 +166,12 @@
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 /*
@@ -248,10 +250,32 @@
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.
@@ -774,16 +798,19 @@
774 ** Tcl script succeeds, start a Tcl event loop until there are no more events
775 ** remaining to process -OR- the script calls [exit]. If the bWait argument
776 ** is zero, only process events that are already in the queue; otherwise,
777 ** process events until the script terminates the Tcl event loop.
778 */
 
 
779 int evaluateTclWithEvents(
780 Th_Interp *interp,
781 void *pContext,
782 const char *zScript,
783 int nScript,
784 int bWait
 
785 ){
786 struct TclContext *tclContext = (struct TclContext *)pContext;
787 Tcl_Interp *tclInterp;
788 int rc;
789 int flags = TCL_ALL_EVENTS;
@@ -791,11 +818,18 @@
791 if( createTclInterp(interp, pContext)!=TH_OK ){
792 return TH_ERROR;
793 }
794 tclInterp = tclContext->interp;
795 rc = Tcl_EvalEx(tclInterp, zScript, nScript, TCL_EVAL_GLOBAL);
796 if( rc!=TCL_OK ) return rc;
 
 
 
 
 
 
 
797 if( !bWait ) flags |= TCL_DONT_WAIT;
798 while( Tcl_DoOneEvent(flags) ){
799 /* do nothing */
800 }
801 return rc;
802
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -20,10 +20,11 @@
20 */
21 #include "config.h"
22
23 #ifdef FOSSIL_ENABLE_TCL
24
25 #include "sqlite3.h"
26 #include "th.h"
27 #include "tcl.h"
28
29 /*
30 ** These macros are designed to reduce the redundant code required to marshal
@@ -165,11 +166,12 @@
166 /*
167 ** HACK: Using some preprocessor magic and a private static variable, redirect
168 ** the Tcl API calls [found within this file] to the function pointers
169 ** that will be contained in our private Tcl stubs table. This takes
170 ** advantage of the fact that the Tcl headers always define the Tcl API
171 ** functions in terms of the "tclStubsPtr" variable when the define
172 ** USE_TCL_STUBS is present during compilation.
173 */
174 #define tclStubsPtr privateTclStubsPtr
175 static const TclStubs *tclStubsPtr = NULL;
176
177 /*
@@ -248,10 +250,32 @@
250 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
251 ** by the caller. This must be declared here because quite a few functions in
252 ** this file need to use it before it can be defined.
253 */
254 static int createTclInterp(Th_Interp *interp, void *pContext);
255
256 /*
257 ** Returns a name for a Tcl return code.
258 */
259 static const char *getTclReturnCodeName(
260 int rc,
261 int nullIfOk
262 ){
263 static char zRc[32];
264
265 switch( rc ){
266 case TCL_OK: return nullIfOk ? 0 : "TCL_OK";
267 case TCL_ERROR: return "TCL_ERROR";
268 case TCL_BREAK: return "TCL_BREAK";
269 case TCL_RETURN: return "TCL_RETURN";
270 case TCL_CONTINUE: return "TCL_CONTINUE";
271 default: {
272 sqlite3_snprintf(sizeof(zRc), zRc, "Tcl return code %d", rc);
273 }
274 }
275 return zRc;
276 }
277
278 /*
279 ** Returns the Tcl interpreter result as a string with the associated length.
280 ** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
281 ** If the length pointer is NULL, the length will not be stored.
@@ -774,16 +798,19 @@
798 ** Tcl script succeeds, start a Tcl event loop until there are no more events
799 ** remaining to process -OR- the script calls [exit]. If the bWait argument
800 ** is zero, only process events that are already in the queue; otherwise,
801 ** process events until the script terminates the Tcl event loop.
802 */
803 void fossil_print(const char *zFormat, ...); /* printf.h */
804
805 int evaluateTclWithEvents(
806 Th_Interp *interp,
807 void *pContext,
808 const char *zScript,
809 int nScript,
810 int bWait,
811 int bVerbose
812 ){
813 struct TclContext *tclContext = (struct TclContext *)pContext;
814 Tcl_Interp *tclInterp;
815 int rc;
816 int flags = TCL_ALL_EVENTS;
@@ -791,11 +818,18 @@
818 if( createTclInterp(interp, pContext)!=TH_OK ){
819 return TH_ERROR;
820 }
821 tclInterp = tclContext->interp;
822 rc = Tcl_EvalEx(tclInterp, zScript, nScript, TCL_EVAL_GLOBAL);
823 if( rc!=TCL_OK ){
824 if( bVerbose ){
825 const char *zResult = getTclResult(tclInterp, 0);
826 fossil_print("%s: ", getTclReturnCodeName(rc, 0));
827 fossil_print("%s\n", zResult);
828 }
829 return rc;
830 }
831 if( !bWait ) flags |= TCL_DONT_WAIT;
832 while( Tcl_DoOneEvent(flags) ){
833 /* do nothing */
834 }
835 return rc;
836

Keyboard Shortcuts

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