Check-in [946c3eb640]
Not logged in

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: 946c3eb6400263c6b407fa735368a67fd3656733
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
Unified Diff Ignore Whitespace Patch
Changes to src/diffcmd.c.
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)==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







|







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
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);
#endif

/*
** General purpose hash table from th_lang.c.
*/
typedef struct Th_Hash      Th_Hash;
typedef struct Th_HashEntry Th_HashEntry;







|







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
170

171
172
173
174
175
176
177
*/
#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.

*/
#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







|
>







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
784

785
786
787
788
789
790
791
792
793
794
795
796







797
798
799
800
801
802
803
/*
** 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,
  int bWait

){
  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 ) return rc;







  if( !bWait ) flags |= TCL_DONT_WAIT;
  while( Tcl_DoOneEvent(flags) ){
    /* do nothing */
  }
  return rc;
}








>
>





|
>











|
>
>
>
>
>
>
>







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;
}