Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Minor enhancements to the Tcl integration subsystem. |
|---|---|
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: |
946c3eb6400263c6b407fa735368a67f |
| User & Date: | mistachkin 2014-09-05 06:23:32.019 |
Context
|
2014-09-07
| ||
| 03:41 | Fix a c99-ism (non-constant initializer). check-in: 128f606fda user: edward tags: trunk | |
| 00:41 | When TH1 'transfer hooks' are enabled, provide the list of UUIDs received by the server to the script. Closed-Leaf check-in: acb61e5ee9 user: mistachkin tags: xferUuidList | |
|
2014-09-05
| ||
| 06:23 | Minor enhancements to the Tcl integration subsystem. check-in: 946c3eb640 user: mistachkin tags: trunk | |
| 06:12 | Style cleanup for return code to name mappings. check-in: 2212ac40a8 user: mistachkin tags: trunk | |
Changes
Changes to src/diffcmd.c.
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 |
if( zTempFile ){
blob_write_to_file(&script, zTempFile);
fossil_print("To see diff, run: tclsh \"%s\"\n", zTempFile);
}else{
#if defined(FOSSIL_ENABLE_TCL)
Th_FossilInit(TH_INIT_DEFAULT);
if( evaluateTclWithEvents(g.interp, &g.tcl, blob_str(&script),
| | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 |
if( zTempFile ){
blob_write_to_file(&script, zTempFile);
fossil_print("To see diff, run: tclsh \"%s\"\n", zTempFile);
}else{
#if defined(FOSSIL_ENABLE_TCL)
Th_FossilInit(TH_INIT_DEFAULT);
if( evaluateTclWithEvents(g.interp, &g.tcl, blob_str(&script),
blob_size(&script), 1, 0)==TCL_OK ){
blob_reset(&script);
return;
}
/*
* If evaluation of the Tcl script fails, the reason may be that Tk
* could not be found by the loaded Tcl, or that Tcl cannot be loaded
* dynamically (e.g. x64 Tcl with x86 Fossil). Therefore, fallback
|
| ︙ | ︙ |
Changes to src/th.h.
| ︙ | ︙ | |||
164 165 166 167 168 169 170 | #ifdef FOSSIL_ENABLE_TCL /* ** Interfaces to the full Tcl core library from "th_tcl.c". */ int th_register_tcl(Th_Interp *, void *); int unloadTcl(Th_Interp *, void *); | | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | #ifdef FOSSIL_ENABLE_TCL /* ** Interfaces to the full Tcl core library from "th_tcl.c". */ int th_register_tcl(Th_Interp *, void *); int unloadTcl(Th_Interp *, void *); int evaluateTclWithEvents(Th_Interp *, void *, const char *, int, int, int); #endif /* ** General purpose hash table from th_lang.c. */ typedef struct Th_Hash Th_Hash; typedef struct Th_HashEntry Th_HashEntry; |
| ︙ | ︙ |
Changes to src/th_tcl.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 | ** ** This file contains code used to bridge the TH1 and Tcl scripting languages. */ #include "config.h" #ifdef FOSSIL_ENABLE_TCL #include "th.h" #include "tcl.h" /* ** These macros are designed to reduce the redundant code required to marshal ** arguments from TH1 to Tcl. */ | > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | ** ** This file contains code used to bridge the TH1 and Tcl scripting languages. */ #include "config.h" #ifdef FOSSIL_ENABLE_TCL #include "sqlite3.h" #include "th.h" #include "tcl.h" /* ** These macros are designed to reduce the redundant code required to marshal ** arguments from TH1 to Tcl. */ |
| ︙ | ︙ | |||
163 164 165 166 167 168 169 | */ #if defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS) /* ** HACK: Using some preprocessor magic and a private static variable, redirect ** the Tcl API calls [found within this file] to the function pointers ** that will be contained in our private Tcl stubs table. This takes ** advantage of the fact that the Tcl headers always define the Tcl API | | > | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 | */ #if defined(FOSSIL_ENABLE_TCL_PRIVATE_STUBS) /* ** HACK: Using some preprocessor magic and a private static variable, redirect ** the Tcl API calls [found within this file] to the function pointers ** that will be contained in our private Tcl stubs table. This takes ** advantage of the fact that the Tcl headers always define the Tcl API ** functions in terms of the "tclStubsPtr" variable when the define ** USE_TCL_STUBS is present during compilation. */ #define tclStubsPtr privateTclStubsPtr static const TclStubs *tclStubsPtr = NULL; /* ** Create a Tcl interpreter structure that mirrors just enough fields to get ** it up and running successfully with our private implementation of the Tcl |
| ︙ | ︙ | |||
246 247 248 249 250 251 252 253 254 255 256 257 258 259 | /* ** Creates and initializes a Tcl interpreter for use with the specified TH1 ** interpreter. Stores the created Tcl interpreter in the Tcl context supplied ** by the caller. This must be declared here because quite a few functions in ** this file need to use it before it can be defined. */ static int createTclInterp(Th_Interp *interp, void *pContext); /* ** Returns the Tcl interpreter result as a string with the associated length. ** If the Tcl interpreter or the Tcl result are NULL, the length will be 0. ** If the length pointer is NULL, the length will not be stored. */ static char *getTclResult( | > > > > > > > > > > > > > > > > > > > > > > | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
/*
** Creates and initializes a Tcl interpreter for use with the specified TH1
** interpreter. Stores the created Tcl interpreter in the Tcl context supplied
** by the caller. This must be declared here because quite a few functions in
** this file need to use it before it can be defined.
*/
static int createTclInterp(Th_Interp *interp, void *pContext);
/*
** Returns a name for a Tcl return code.
*/
static const char *getTclReturnCodeName(
int rc,
int nullIfOk
){
static char zRc[32];
switch( rc ){
case TCL_OK: return nullIfOk ? 0 : "TCL_OK";
case TCL_ERROR: return "TCL_ERROR";
case TCL_BREAK: return "TCL_BREAK";
case TCL_RETURN: return "TCL_RETURN";
case TCL_CONTINUE: return "TCL_CONTINUE";
default: {
sqlite3_snprintf(sizeof(zRc), zRc, "Tcl return code %d", rc);
}
}
return zRc;
}
/*
** Returns the Tcl interpreter result as a string with the associated length.
** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
** If the length pointer is NULL, the length will not be stored.
*/
static char *getTclResult(
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 779 780 781 782 783 | /* ** Evaluate a Tcl script, creating the Tcl interpreter if necessary. If the ** Tcl script succeeds, start a Tcl event loop until there are no more events ** remaining to process -OR- the script calls [exit]. If the bWait argument ** is zero, only process events that are already in the queue; otherwise, ** process events until the script terminates the Tcl event loop. */ int evaluateTclWithEvents( Th_Interp *interp, void *pContext, const char *zScript, int nScript, | > > | > | > > > > > > > | 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 |
/*
** Evaluate a Tcl script, creating the Tcl interpreter if necessary. If the
** Tcl script succeeds, start a Tcl event loop until there are no more events
** remaining to process -OR- the script calls [exit]. If the bWait argument
** is zero, only process events that are already in the queue; otherwise,
** process events until the script terminates the Tcl event loop.
*/
void fossil_print(const char *zFormat, ...); /* printf.h */
int evaluateTclWithEvents(
Th_Interp *interp,
void *pContext,
const char *zScript,
int nScript,
int bWait,
int bVerbose
){
struct TclContext *tclContext = (struct TclContext *)pContext;
Tcl_Interp *tclInterp;
int rc;
int flags = TCL_ALL_EVENTS;
if( createTclInterp(interp, pContext)!=TH_OK ){
return TH_ERROR;
}
tclInterp = tclContext->interp;
rc = Tcl_EvalEx(tclInterp, zScript, nScript, TCL_EVAL_GLOBAL);
if( rc!=TCL_OK ){
if( bVerbose ){
const char *zResult = getTclResult(tclInterp, 0);
fossil_print("%s: ", getTclReturnCodeName(rc, 0));
fossil_print("%s\n", zResult);
}
return rc;
}
if( !bWait ) flags |= TCL_DONT_WAIT;
while( Tcl_DoOneEvent(flags) ){
/* do nothing */
}
return rc;
}
|
| ︙ | ︙ |