Fossil SCM

Further improvements to the Tcl integration subsystem.

mistachkin 2015-06-11 21:25 trunk
Commit 18fc492a95b0ce408a9a84abfa0eb8d402122978
Parent 0626182eb38a866…
4 files changed +1 -1 +1 +1 -1 +36 -5
~ src/diffcmd.c ~ src/main.c ~ src/th.h ~ src/th_tcl.c
M src/diffcmd.c
+1 -1
--- src/diffcmd.c
+++ src/diffcmd.c
@@ -662,11 +662,11 @@
662662
 fossil_print("To see diff, run: tclsh \"%s\"\n", zTempFile);
663663
 }else{
664664
 #if defined(FOSSIL_ENABLE_TCL)
665665
 Th_FossilInit(TH_INIT_DEFAULT);
666666
 if( evaluateTclWithEvents(g.interp, &g.tcl, blob_str(&script),
667
- blob_size(&script), 1, 0)==TCL_OK ){
667
+ blob_size(&script), 1, 1, 0)==TCL_OK ){
668668
 blob_reset(&script);
669669
 return;
670670
 }
671671
 /*
672672
 * If evaluation of the Tcl script fails, the reason may be that Tk
673673
--- src/diffcmd.c
+++ src/diffcmd.c
@@ -662,11 +662,11 @@
662 fossil_print("To see diff, run: tclsh \"%s\"\n", zTempFile);
663 }else{
664 #if defined(FOSSIL_ENABLE_TCL)
665 Th_FossilInit(TH_INIT_DEFAULT);
666 if( evaluateTclWithEvents(g.interp, &g.tcl, blob_str(&script),
667 blob_size(&script), 1, 0)==TCL_OK ){
668 blob_reset(&script);
669 return;
670 }
671 /*
672 * If evaluation of the Tcl script fails, the reason may be that Tk
673
--- src/diffcmd.c
+++ src/diffcmd.c
@@ -662,11 +662,11 @@
662 fossil_print("To see diff, run: tclsh \"%s\"\n", zTempFile);
663 }else{
664 #if defined(FOSSIL_ENABLE_TCL)
665 Th_FossilInit(TH_INIT_DEFAULT);
666 if( evaluateTclWithEvents(g.interp, &g.tcl, blob_str(&script),
667 blob_size(&script), 1, 1, 0)==TCL_OK ){
668 blob_reset(&script);
669 return;
670 }
671 /*
672 * If evaluation of the Tcl script fails, the reason may be that Tk
673
M src/main.c
+1
--- src/main.c
+++ src/main.c
@@ -109,10 +109,11 @@
109109
 void *xCreateInterp; /* See tcl_CreateInterpProc in th_tcl.c. */
110110
 void *xDeleteInterp; /* See tcl_DeleteInterpProc in th_tcl.c. */
111111
 void *xFinalize; /* See tcl_FinalizeProc in th_tcl.c. */
112112
 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
113113
 int useObjProc; /* Non-zero if an objProc can be called directly. */
114
+ int useTip285; /* Non-zero if TIP #285 is available. */
114115
 char *setup; /* The optional Tcl setup script. */
115116
 void *xPreEval; /* Optional, called before Tcl_Eval*(). */
116117
 void *pPreContext; /* Optional, provided to xPreEval(). */
117118
 void *xPostEval; /* Optional, called after Tcl_Eval*(). */
118119
 void *pPostContext; /* Optional, provided to xPostEval(). */
119120
--- src/main.c
+++ src/main.c
@@ -109,10 +109,11 @@
109 void *xCreateInterp; /* See tcl_CreateInterpProc in th_tcl.c. */
110 void *xDeleteInterp; /* See tcl_DeleteInterpProc in th_tcl.c. */
111 void *xFinalize; /* See tcl_FinalizeProc in th_tcl.c. */
112 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
113 int useObjProc; /* Non-zero if an objProc can be called directly. */
 
114 char *setup; /* The optional Tcl setup script. */
115 void *xPreEval; /* Optional, called before Tcl_Eval*(). */
116 void *pPreContext; /* Optional, provided to xPreEval(). */
117 void *xPostEval; /* Optional, called after Tcl_Eval*(). */
118 void *pPostContext; /* Optional, provided to xPostEval(). */
119
--- src/main.c
+++ src/main.c
@@ -109,10 +109,11 @@
109 void *xCreateInterp; /* See tcl_CreateInterpProc in th_tcl.c. */
110 void *xDeleteInterp; /* See tcl_DeleteInterpProc in th_tcl.c. */
111 void *xFinalize; /* See tcl_FinalizeProc in th_tcl.c. */
112 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
113 int useObjProc; /* Non-zero if an objProc can be called directly. */
114 int useTip285; /* Non-zero if TIP #285 is available. */
115 char *setup; /* The optional Tcl setup script. */
116 void *xPreEval; /* Optional, called before Tcl_Eval*(). */
117 void *pPreContext; /* Optional, provided to xPreEval(). */
118 void *xPostEval; /* Optional, called after Tcl_Eval*(). */
119 void *pPostContext; /* Optional, provided to xPostEval(). */
120
M src/th.h
+1 -1
--- src/th.h
+++ src/th.h
@@ -172,11 +172,11 @@
172172
 /*
173173
 ** Interfaces to the full Tcl core library from "th_tcl.c".
174174
 */
175175
 int th_register_tcl(Th_Interp *, void *);
176176
 int unloadTcl(Th_Interp *, void *);
177
-int evaluateTclWithEvents(Th_Interp *, void *, const char *, int, int, int);
177
+int evaluateTclWithEvents(Th_Interp *,void *,const char *,int,int,int,int);
178178
 #endif
179179
180180
 /*
181181
 ** General purpose hash table from th_lang.c.
182182
 */
183183
--- src/th.h
+++ src/th.h
@@ -172,11 +172,11 @@
172 /*
173 ** Interfaces to the full Tcl core library from "th_tcl.c".
174 */
175 int th_register_tcl(Th_Interp *, void *);
176 int unloadTcl(Th_Interp *, void *);
177 int evaluateTclWithEvents(Th_Interp *, void *, const char *, int, int, int);
178 #endif
179
180 /*
181 ** General purpose hash table from th_lang.c.
182 */
183
--- src/th.h
+++ src/th.h
@@ -172,11 +172,11 @@
172 /*
173 ** Interfaces to the full Tcl core library from "th_tcl.c".
174 */
175 int th_register_tcl(Th_Interp *, void *);
176 int unloadTcl(Th_Interp *, void *);
177 int evaluateTclWithEvents(Th_Interp *,void *,const char *,int,int,int,int);
178 #endif
179
180 /*
181 ** General purpose hash table from th_lang.c.
182 */
183
M src/th_tcl.c
+36 -5
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -167,13 +167,13 @@
167167
 ** the only Tcl API functions that MUST be called prior to being able to call
168168
 ** Tcl_InitStubs (i.e. because it requires a Tcl interpreter). For complete
169169
 ** cleanup if the Tcl stubs initialization fails somehow, the Tcl_DeleteInterp
170170
 ** and Tcl_Finalize function types are also required.
171171
 */
172
-typedef void (tcl_FindExecutableProc) (const char * argv0);
172
+typedef void (tcl_FindExecutableProc) (const char *);
173173
 typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
174
-typedef void (tcl_DeleteInterpProc) (Tcl_Interp *interp);
174
+typedef void (tcl_DeleteInterpProc) (Tcl_Interp *);
175175
 typedef void (tcl_FinalizeProc) (void);
176176
177177
 /*
178178
 ** The function types for the "hook" functions to be called before and after a
179179
 ** TH1 command makes a call to evaluate a Tcl script. If the "pre" function
@@ -277,10 +277,25 @@
277277
 if( major==8 && minor==6 && type==TCL_BETA_RELEASE && patchLevel<3 ){
278278
 return 0; /* NOTE: Disabled on Tcl 8.6b1/b2, SF bug #3399564. */
279279
 }
280280
 return 1; /* NOTE: For all other cases, assume good. */
281281
 }
282
+
283
+/*
284
+** Is the loaded version of Tcl one where TIP #285 (asynchronous script
285
+** cancellation) is available? This should return non-zero only for Tcl
286
+** 8.6 and higher.
287
+*/
288
+static int canUseTip285(){
289
+ int major = -1, minor = -1, patchLevel = -1, type = -1;
290
+
291
+ Tcl_GetVersion(&major, &minor, &patchLevel, &type);
292
+ if( major<0 || minor<0 || patchLevel<0 || type<0 ){
293
+ return 0; /* NOTE: Invalid version info, assume bad. */
294
+ }
295
+ return (major>8 || (major==8 && minor>=6));
296
+}
282297
283298
 /*
284299
 ** Creates and initializes a Tcl interpreter for use with the specified TH1
285300
 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
286301
 ** by the caller. This must be declared here because quite a few functions in
@@ -379,10 +394,11 @@
379394
 tcl_CreateInterpProc *xCreateInterp; /* Tcl_CreateInterp() pointer. */
380395
 tcl_DeleteInterpProc *xDeleteInterp; /* Tcl_DeleteInterp() pointer. */
381396
 tcl_FinalizeProc *xFinalize; /* Tcl_Finalize() pointer. */
382397
 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
383398
 int useObjProc; /* Non-zero if an objProc can be called directly. */
399
+ int useTip285; /* Non-zero if TIP #285 is available. */
384400
 char *setup; /* The optional Tcl setup script. */
385401
 tcl_NotifyProc *xPreEval; /* Optional, called before Tcl_Eval*(). */
386402
 void *pPreContext; /* Optional, provided to xPreEval(). */
387403
 tcl_NotifyProc *xPostEval; /* Optional, called after Tcl_Eval*(). */
388404
 void *pPostContext; /* Optional, provided to xPostEval(). */
@@ -923,22 +939,25 @@
923939
 int evaluateTclWithEvents(
924940
 Th_Interp *interp,
925941
 void *pContext,
926942
 const char *zScript,
927943
 int nScript,
944
+ int bCancel,
928945
 int bWait,
929946
 int bVerbose
930947
 ){
931948
 struct TclContext *tclContext = (struct TclContext *)pContext;
932949
 Tcl_Interp *tclInterp;
933950
 int rc;
934951
 int flags = TCL_ALL_EVENTS;
952
+ int useTip285;
935953
936954
 if( createTclInterp(interp, pContext)!=TH_OK ){
937955
 return TH_ERROR;
938956
 }
939957
 tclInterp = tclContext->interp;
958
+ useTip285 = bCancel ? tclContext->useTip285 : 0;
940959
 rc = Tcl_EvalEx(tclInterp, zScript, nScript, TCL_EVAL_GLOBAL);
941960
 if( rc!=TCL_OK ){
942961
 if( bVerbose ){
943962
 const char *zResult = getTclResult(tclInterp, 0);
944963
 fossil_print("%s: ", getTclReturnCodeName(rc, 0));
@@ -945,13 +964,20 @@
945964
 fossil_print("%s\n", zResult);
946965
 }
947966
 return rc;
948967
 }
949968
 if( !bWait ) flags |= TCL_DONT_WAIT;
969
+ Tcl_Preserve((ClientData)tclInterp);
950970
 while( Tcl_DoOneEvent(flags) ){
951
- /* do nothing */
971
+ if( Tcl_InterpDeleted(tclInterp) ){
972
+ break;
973
+ }
974
+ if( useTip285 && Tcl_Canceled(tclInterp, 0)!=TCL_OK ){
975
+ break;
976
+ }
952977
 }
978
+ Tcl_Release((ClientData)tclInterp);
953979
 return rc;
954980
 }
955981
956982
 /*
957983
 ** Creates and initializes a Tcl interpreter for use with the specified TH1
@@ -1032,14 +1058,19 @@
10321058
 Tcl_DeleteInterp(tclInterp);
10331059
 tclContext->interp = tclInterp = 0;
10341060
 return TH_ERROR;
10351061
 }
10361062
 /*
1037
- ** Determine if an objProc can be called directly for a Tcl command invoked
1038
- ** via the tclInvoke TH1 command.
1063
+ ** Determine (and cache) if an objProc can be called directly for a Tcl
1064
+ ** command invoked via the tclInvoke TH1 command.
10391065
 */
10401066
 tclContext->useObjProc = canUseObjProc();
1067
+ /*
1068
+ ** Determine (and cache) whether or not we can use TIP #285 (asynchronous
1069
+ ** script cancellation).
1070
+ */
1071
+ tclContext->useTip285 = canUseTip285();
10411072
 /* Add the TH1 integration commands to Tcl. */
10421073
 Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
10431074
 Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
10441075
 Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
10451076
 /* If necessary, evaluate the custom Tcl setup script. */
10461077
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -167,13 +167,13 @@
167 ** the only Tcl API functions that MUST be called prior to being able to call
168 ** Tcl_InitStubs (i.e. because it requires a Tcl interpreter). For complete
169 ** cleanup if the Tcl stubs initialization fails somehow, the Tcl_DeleteInterp
170 ** and Tcl_Finalize function types are also required.
171 */
172 typedef void (tcl_FindExecutableProc) (const char * argv0);
173 typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
174 typedef void (tcl_DeleteInterpProc) (Tcl_Interp *interp);
175 typedef void (tcl_FinalizeProc) (void);
176
177 /*
178 ** The function types for the "hook" functions to be called before and after a
179 ** TH1 command makes a call to evaluate a Tcl script. If the "pre" function
@@ -277,10 +277,25 @@
277 if( major==8 && minor==6 && type==TCL_BETA_RELEASE && patchLevel<3 ){
278 return 0; /* NOTE: Disabled on Tcl 8.6b1/b2, SF bug #3399564. */
279 }
280 return 1; /* NOTE: For all other cases, assume good. */
281 }
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
282
283 /*
284 ** Creates and initializes a Tcl interpreter for use with the specified TH1
285 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
286 ** by the caller. This must be declared here because quite a few functions in
@@ -379,10 +394,11 @@
379 tcl_CreateInterpProc *xCreateInterp; /* Tcl_CreateInterp() pointer. */
380 tcl_DeleteInterpProc *xDeleteInterp; /* Tcl_DeleteInterp() pointer. */
381 tcl_FinalizeProc *xFinalize; /* Tcl_Finalize() pointer. */
382 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
383 int useObjProc; /* Non-zero if an objProc can be called directly. */
 
384 char *setup; /* The optional Tcl setup script. */
385 tcl_NotifyProc *xPreEval; /* Optional, called before Tcl_Eval*(). */
386 void *pPreContext; /* Optional, provided to xPreEval(). */
387 tcl_NotifyProc *xPostEval; /* Optional, called after Tcl_Eval*(). */
388 void *pPostContext; /* Optional, provided to xPostEval(). */
@@ -923,22 +939,25 @@
923 int evaluateTclWithEvents(
924 Th_Interp *interp,
925 void *pContext,
926 const char *zScript,
927 int nScript,
 
928 int bWait,
929 int bVerbose
930 ){
931 struct TclContext *tclContext = (struct TclContext *)pContext;
932 Tcl_Interp *tclInterp;
933 int rc;
934 int flags = TCL_ALL_EVENTS;
 
935
936 if( createTclInterp(interp, pContext)!=TH_OK ){
937 return TH_ERROR;
938 }
939 tclInterp = tclContext->interp;
 
940 rc = Tcl_EvalEx(tclInterp, zScript, nScript, TCL_EVAL_GLOBAL);
941 if( rc!=TCL_OK ){
942 if( bVerbose ){
943 const char *zResult = getTclResult(tclInterp, 0);
944 fossil_print("%s: ", getTclReturnCodeName(rc, 0));
@@ -945,13 +964,20 @@
945 fossil_print("%s\n", zResult);
946 }
947 return rc;
948 }
949 if( !bWait ) flags |= TCL_DONT_WAIT;
 
950 while( Tcl_DoOneEvent(flags) ){
951 /* do nothing */
 
 
 
 
 
952 }
 
953 return rc;
954 }
955
956 /*
957 ** Creates and initializes a Tcl interpreter for use with the specified TH1
@@ -1032,14 +1058,19 @@
1032 Tcl_DeleteInterp(tclInterp);
1033 tclContext->interp = tclInterp = 0;
1034 return TH_ERROR;
1035 }
1036 /*
1037 ** Determine if an objProc can be called directly for a Tcl command invoked
1038 ** via the tclInvoke TH1 command.
1039 */
1040 tclContext->useObjProc = canUseObjProc();
 
 
 
 
 
1041 /* Add the TH1 integration commands to Tcl. */
1042 Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
1043 Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
1044 Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
1045 /* If necessary, evaluate the custom Tcl setup script. */
1046
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -167,13 +167,13 @@
167 ** the only Tcl API functions that MUST be called prior to being able to call
168 ** Tcl_InitStubs (i.e. because it requires a Tcl interpreter). For complete
169 ** cleanup if the Tcl stubs initialization fails somehow, the Tcl_DeleteInterp
170 ** and Tcl_Finalize function types are also required.
171 */
172 typedef void (tcl_FindExecutableProc) (const char *);
173 typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
174 typedef void (tcl_DeleteInterpProc) (Tcl_Interp *);
175 typedef void (tcl_FinalizeProc) (void);
176
177 /*
178 ** The function types for the "hook" functions to be called before and after a
179 ** TH1 command makes a call to evaluate a Tcl script. If the "pre" function
@@ -277,10 +277,25 @@
277 if( major==8 && minor==6 && type==TCL_BETA_RELEASE && patchLevel<3 ){
278 return 0; /* NOTE: Disabled on Tcl 8.6b1/b2, SF bug #3399564. */
279 }
280 return 1; /* NOTE: For all other cases, assume good. */
281 }
282
283 /*
284 ** Is the loaded version of Tcl one where TIP #285 (asynchronous script
285 ** cancellation) is available? This should return non-zero only for Tcl
286 ** 8.6 and higher.
287 */
288 static int canUseTip285(){
289 int major = -1, minor = -1, patchLevel = -1, type = -1;
290
291 Tcl_GetVersion(&major, &minor, &patchLevel, &type);
292 if( major<0 || minor<0 || patchLevel<0 || type<0 ){
293 return 0; /* NOTE: Invalid version info, assume bad. */
294 }
295 return (major>8 || (major==8 && minor>=6));
296 }
297
298 /*
299 ** Creates and initializes a Tcl interpreter for use with the specified TH1
300 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
301 ** by the caller. This must be declared here because quite a few functions in
@@ -379,10 +394,11 @@
394 tcl_CreateInterpProc *xCreateInterp; /* Tcl_CreateInterp() pointer. */
395 tcl_DeleteInterpProc *xDeleteInterp; /* Tcl_DeleteInterp() pointer. */
396 tcl_FinalizeProc *xFinalize; /* Tcl_Finalize() pointer. */
397 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
398 int useObjProc; /* Non-zero if an objProc can be called directly. */
399 int useTip285; /* Non-zero if TIP #285 is available. */
400 char *setup; /* The optional Tcl setup script. */
401 tcl_NotifyProc *xPreEval; /* Optional, called before Tcl_Eval*(). */
402 void *pPreContext; /* Optional, provided to xPreEval(). */
403 tcl_NotifyProc *xPostEval; /* Optional, called after Tcl_Eval*(). */
404 void *pPostContext; /* Optional, provided to xPostEval(). */
@@ -923,22 +939,25 @@
939 int evaluateTclWithEvents(
940 Th_Interp *interp,
941 void *pContext,
942 const char *zScript,
943 int nScript,
944 int bCancel,
945 int bWait,
946 int bVerbose
947 ){
948 struct TclContext *tclContext = (struct TclContext *)pContext;
949 Tcl_Interp *tclInterp;
950 int rc;
951 int flags = TCL_ALL_EVENTS;
952 int useTip285;
953
954 if( createTclInterp(interp, pContext)!=TH_OK ){
955 return TH_ERROR;
956 }
957 tclInterp = tclContext->interp;
958 useTip285 = bCancel ? tclContext->useTip285 : 0;
959 rc = Tcl_EvalEx(tclInterp, zScript, nScript, TCL_EVAL_GLOBAL);
960 if( rc!=TCL_OK ){
961 if( bVerbose ){
962 const char *zResult = getTclResult(tclInterp, 0);
963 fossil_print("%s: ", getTclReturnCodeName(rc, 0));
@@ -945,13 +964,20 @@
964 fossil_print("%s\n", zResult);
965 }
966 return rc;
967 }
968 if( !bWait ) flags |= TCL_DONT_WAIT;
969 Tcl_Preserve((ClientData)tclInterp);
970 while( Tcl_DoOneEvent(flags) ){
971 if( Tcl_InterpDeleted(tclInterp) ){
972 break;
973 }
974 if( useTip285 && Tcl_Canceled(tclInterp, 0)!=TCL_OK ){
975 break;
976 }
977 }
978 Tcl_Release((ClientData)tclInterp);
979 return rc;
980 }
981
982 /*
983 ** Creates and initializes a Tcl interpreter for use with the specified TH1
@@ -1032,14 +1058,19 @@
1058 Tcl_DeleteInterp(tclInterp);
1059 tclContext->interp = tclInterp = 0;
1060 return TH_ERROR;
1061 }
1062 /*
1063 ** Determine (and cache) if an objProc can be called directly for a Tcl
1064 ** command invoked via the tclInvoke TH1 command.
1065 */
1066 tclContext->useObjProc = canUseObjProc();
1067 /*
1068 ** Determine (and cache) whether or not we can use TIP #285 (asynchronous
1069 ** script cancellation).
1070 */
1071 tclContext->useTip285 = canUseTip285();
1072 /* Add the TH1 integration commands to Tcl. */
1073 Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
1074 Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
1075 Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
1076 /* If necessary, evaluate the custom Tcl setup script. */
1077

Keyboard Shortcuts

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