Fossil

Check-in [53b9445b]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Use macros to tidy up TH1 to Tcl argument marshalling. Use the Tcl interp result when Tcl_ExprObj does not return ok. Check for Tcl interp deletion. The TH1 'puts' command should flush when writing to stdout. Add 'repository' TH1 command. Use obj API to get Tcl cmdInfo. Add tests for Tcl integration.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tcl-integration
Files: files | file ages | folders
SHA1: 53b9445b2c048214c6e649284aa4bfd02bd4a8b6
User & Date: mistachkin 2011-08-28 23:45:18
Context
2011-08-29
00:28
Fix comment regarding the value of TCLDIR. check-in: 10f13bc5 user: mistachkin tags: tcl-integration
2011-08-28
23:45
Use macros to tidy up TH1 to Tcl argument marshalling. Use the Tcl interp result when Tcl_ExprObj does not return ok. Check for Tcl interp deletion. The TH1 'puts' command should flush when writing to stdout. Add 'repository' TH1 command. Use obj API to get Tcl cmdInfo. Add tests for Tcl integration. check-in: 53b9445b user: mistachkin tags: tcl-integration
06:54
Reset result prior to direct Tcl invocation. Cast all ckalloc return values. Make sure the global config database is open for the 'test_th_render' command. Allow the 'tcl' setting to be enabled via the environment. check-in: 5cc15d08 user: mistachkin tags: tcl-integration
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to src/th_main.c.

91
92
93
94
95
96
97

98
99
100
101
102
103
104
...
332
333
334
335
336
337
338





























339
340
341
342
343
344
345
...
355
356
357
358
359
360
361

362
363
364
365
366
367
368
      z = htmlize(z, n);
      n = strlen(z);
    }
    if( g.cgiOutput ){
      cgi_append_content(z, n);
    }else{
      fwrite(z, 1, n, stdout);

    }
    if( encode ) free((char*)z);
  }
}

/*
** TH command:     puts STRING
................................................................................
    }
  }
  if( n<iMin ) n = iMin;
  if( n>iMax ) n = iMax;
  Th_SetResultInt(interp, n);
  return TH_OK;
}






























/*
** Make sure the interpreter has been initialized.  Initialize it if
** it has not been already.
**
** The interpreter is stored in the g.interp global variable.
*/
................................................................................
    {"linecount",     linecntCmd,           0},
    {"hascap",        hascapCmd,            0},
    {"htmlize",       htmlizeCmd,           0},
    {"date",          dateCmd,              0},
    {"html",          putsCmd,              0},
    {"puts",          putsCmd,       (void*)1},
    {"wiki",          wikiCmd,              0},

  };
  if( g.interp==0 ){
    int i;
    g.interp = Th_CreateInterp(&vtab);
    th_register_language(g.interp);       /* Basic scripting commands. */
#ifdef FOSSIL_ENABLE_TCL
    if( getenv("TH1_ENABLE_TCL")!=0 || db_get_boolean("tcl", 0) ){







>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>







91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
...
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
...
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
      z = htmlize(z, n);
      n = strlen(z);
    }
    if( g.cgiOutput ){
      cgi_append_content(z, n);
    }else{
      fwrite(z, 1, n, stdout);
      fflush(stdout);
    }
    if( encode ) free((char*)z);
  }
}

/*
** TH command:     puts STRING
................................................................................
    }
  }
  if( n<iMin ) n = iMin;
  if( n>iMax ) n = iMax;
  Th_SetResultInt(interp, n);
  return TH_OK;
}

/*
** TH1 command:     repository ?BOOLEAN?
**
** Return the fully qualified file name of the open repository or an empty
** string if one is not currently open.  Optionally, it will attempt to open
** the repository if the boolean argument is non-zero.
*/
static int repositoryCmd(
  Th_Interp *interp,
  void *p, 
  int argc, 
  const char **argv, 
  int *argl
){
  int openRepository;

  if( argc!=1 && argc!=2 ){
    return Th_WrongNumArgs(interp, "repository ?BOOLEAN?");
  }
  if( argc==2 ){
    if( Th_ToInt(interp, argv[1], argl[1], &openRepository) ){
      return TH_ERROR;
    }
    if( openRepository ) db_find_and_open_repository(OPEN_OK_NOT_FOUND, 0);
  }
  Th_SetResult(interp, g.zRepositoryName, -1);
  return TH_OK;
}

/*
** Make sure the interpreter has been initialized.  Initialize it if
** it has not been already.
**
** The interpreter is stored in the g.interp global variable.
*/
................................................................................
    {"linecount",     linecntCmd,           0},
    {"hascap",        hascapCmd,            0},
    {"htmlize",       htmlizeCmd,           0},
    {"date",          dateCmd,              0},
    {"html",          putsCmd,              0},
    {"puts",          putsCmd,       (void*)1},
    {"wiki",          wikiCmd,              0},
    {"repository",    repositoryCmd,        0},
  };
  if( g.interp==0 ){
    int i;
    g.interp = Th_CreateInterp(&vtab);
    th_register_language(g.interp);       /* Basic scripting commands. */
#ifdef FOSSIL_ENABLE_TCL
    if( getenv("TH1_ENABLE_TCL")!=0 || db_get_boolean("tcl", 0) ){

Changes to src/th_tcl.c.

1
2
3
4
5
6
7










































8
9
10
11
12
13
14
..
24
25
26
27
28
29
30
31
32
33
34

35
36
37
38
39
40
41

42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

60
61
62
63
64
65
66
..
79
80
81
82
83
84
85
86
87
88
89

90
91
92
93
94
95
96

97
98
99
100
101
102
103
104
105
106
107
108
109

110


111
112
113
114

115
116
117
118
119
120
121
...
124
125
126
127
128
129
130

131
132
133
134
135
136
137
138

139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
...
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
284

285
286
287
288
289
290
291
292
293
294
295
296
/*
** This file contains code used to bridge the TH1 and Tcl scripting languages.
*/

#include "config.h"
#include "th.h"
#include "tcl.h"











































/*
** Syntax:
**
**   tclEval arg ?arg ...?
*/
static int tclEval_command(
................................................................................
  int nResult;
  const char *zResult;

  if( argc<2 ){
    return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
  }
  tclInterp = (Tcl_Interp *)ctx;
  if( !tclInterp ){
    Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
    return TH_ERROR;
  }

  if( argc==2 ){
    objPtr = Tcl_NewStringObj(argv[1], argl[1]);
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
    Tcl_DecrRefCount(objPtr);
  }else{
    int objc = argc-1;

    Tcl_Obj **objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
    int i;
    for(i=1; i<argc; i++){
      objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
      Tcl_IncrRefCount(objv[i-1]);
    }
    objPtr = Tcl_ConcatObj(objc, objv);
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
    Tcl_DecrRefCount(objPtr);
    for(i=1; i<argc; i++){
      Tcl_DecrRefCount(objv[i-1]);
    }
    ckfree((char *)objv);
  }
  objPtr = Tcl_GetObjResult(tclInterp);
  zResult = Tcl_GetStringFromObj(objPtr, &nResult);
  Th_SetResult(interp, zResult, nResult);

  return rc;
}

/*
** Syntax:
**
**   tclExpr arg ?arg ...?
................................................................................
  int nResult;
  const char *zResult;

  if( argc<2 ){
    return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
  }
  tclInterp = (Tcl_Interp *)ctx;
  if( !tclInterp ){
    Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
    return TH_ERROR;
  }

  if( argc==2 ){
    objPtr = Tcl_NewStringObj(argv[1], argl[1]);
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
    Tcl_DecrRefCount(objPtr);
  }else{
    int objc = argc-1;

    Tcl_Obj **objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
    int i;
    for(i=1; i<argc; i++){
      objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
      Tcl_IncrRefCount(objv[i-1]);
    }
    objPtr = Tcl_ConcatObj(objc, objv);
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
    Tcl_DecrRefCount(objPtr);
    for(i=1; i<argc; i++){
      Tcl_DecrRefCount(objv[i-1]);
    }

    ckfree((char *)objv);


  }
  zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
  Th_SetResult(interp, zResult, nResult);
  Tcl_DecrRefCount(resultObjPtr);

  return rc;
}

/*
** Syntax:
**
**   tclInvoke command ?arg ...?
................................................................................
  Th_Interp *interp,
  void *ctx,
  int argc,
  const char **argv,
  int *argl
){
  Tcl_Interp *tclInterp;

  Tcl_CmdInfo cmdInfo;
  int objc;
  Tcl_Obj **objv;
  int i;
  int rc;
  int nResult;
  const char *zResult;
  Tcl_Obj *objPtr;


  if( argc<2 ){
    return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
  }
  tclInterp = (Tcl_Interp *)ctx;
  if( !tclInterp ){
    Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
    return TH_ERROR;
  }
  if (Tcl_GetCommandInfo(tclInterp, argv[1], &cmdInfo) == 0){
    Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
    return TH_ERROR;
  }
  objc = argc-1;
  objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
  for(i=1; i<argc; i++){
    objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
    Tcl_IncrRefCount(objv[i-1]);
  }
  Tcl_Preserve((ClientData)tclInterp);
  Tcl_ResetResult(tclInterp);
  rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
  for(i=1; i<argc; i++){
    Tcl_DecrRefCount(objv[i-1]);
  }
  ckfree((char *)objv);
  objPtr = Tcl_GetObjResult(tclInterp);
  zResult = Tcl_GetStringFromObj(objPtr, &nResult);
  Th_SetResult(interp, zResult, nResult);
  Tcl_Release((ClientData)tclInterp);
  return rc;
}

/*
** Syntax:
................................................................................
 */
static void Th1DeleteProc(
  ClientData clientData,
  Tcl_Interp *interp
){
  int i;
  Th_Interp *th1Interp = (Th_Interp *)clientData;
  if ( !th1Interp ) return;
  /* Remove the Tcl integration commands. */
  for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
    Th_RenameCommand(th1Interp, aCommand[i].zName, -1, NULL, 0);
  }
}

/*
................................................................................
** Register the Tcl language commands with interpreter interp.
** Usually this is called soon after interpreter creation.
*/
int th_register_tcl(Th_Interp *interp){
  int i;
  Tcl_Interp *tclInterp = Tcl_CreateInterp();

  if( !tclInterp ){
    Th_ErrorMessage(interp,
        "Could not create Tcl interpreter", (const char *)"", 0);
    return TH_ERROR;
  }
  if( Tcl_Init(tclInterp)!=TCL_OK ){
    Th_ErrorMessage(interp,
        "Tcl initialization error:", Tcl_GetStringResult(tclInterp), -1);
    Tcl_DeleteInterp(tclInterp);
    return TH_ERROR;
  }

  Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
  Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
  Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
  /* Add the Tcl integration commands. */
  for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
    void *ctx = aCommand[i].pContext;
    /* Use Tcl interpreter for context? */
    if( !ctx ) ctx = tclInterp;
    Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
  }
  return TH_OK;
}







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|



>






<
>
|
<
<
<
<
<




|
<
|
<
<
|
<

>







 







|



>






<
>
|
<
<
<
<
<




|
<
|
>
|
>
>

<

|
>







 







>

<
<
<




>





|



|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<







 







|







 







|










>



|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
..
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83

84
85





86
87
88
89
90

91


92

93
94
95
96
97
98
99
100
101
...
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

132
133





134
135
136
137
138

139
140
141
142
143
144

145
146
147
148
149
150
151
152
153
154
...
157
158
159
160
161
162
163
164
165



166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195



196
197
198
199
200
201
202
...
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
...
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
/*
** This file contains code used to bridge the TH1 and Tcl scripting languages.
*/

#include "config.h"
#include "th.h"
#include "tcl.h"

/*
** These macros are designed to reduce the redundant code required to marshal
** arguments from TH1 to Tcl.
 */
#define USE_ARGV_TO_OBJV() \
  int objc;                \
  Tcl_Obj **objv;          \
  int i;

#define COPY_ARGV_TO_OBJV()                                         \
  objc = argc-1;                                                    \
  objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *))); \
  for(i=1; i<argc; i++){                                            \
    objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);                 \
    Tcl_IncrRefCount(objv[i-1]);                                    \
  }

#define FREE_ARGV_TO_OBJV()      \
  for(i=1; i<argc; i++){         \
    Tcl_DecrRefCount(objv[i-1]); \
  }                              \
  ckfree((char *)objv);

/*
** 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(Tcl_Interp *pInterp, int *pN){
  Tcl_Obj *resultPtr;
  if( !pInterp ){ /* This should not happen. */
    if( pN ) *pN = 0;
    return 0;
  }
  resultPtr = Tcl_GetObjResult(pInterp);
  if( !resultPtr ){ /* This should not happen either? */
    if( pN ) *pN = 0;
    return 0;
  }
  return Tcl_GetStringFromObj(resultPtr, pN);
}

/*
** Syntax:
**
**   tclEval arg ?arg ...?
*/
static int tclEval_command(
................................................................................
  int nResult;
  const char *zResult;

  if( argc<2 ){
    return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
  }
  tclInterp = (Tcl_Interp *)ctx;
  if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
    Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
    return TH_ERROR;
  }
  Tcl_Preserve((ClientData)tclInterp);
  if( argc==2 ){
    objPtr = Tcl_NewStringObj(argv[1], argl[1]);
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
    Tcl_DecrRefCount(objPtr);
  }else{

    USE_ARGV_TO_OBJV();
    COPY_ARGV_TO_OBJV();





    objPtr = Tcl_ConcatObj(objc, objv);
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
    Tcl_DecrRefCount(objPtr);
    FREE_ARGV_TO_OBJV();

  }


  zResult = getTclResult(tclInterp, &nResult);

  Th_SetResult(interp, zResult, nResult);
  Tcl_Release((ClientData)tclInterp);
  return rc;
}

/*
** Syntax:
**
**   tclExpr arg ?arg ...?
................................................................................
  int nResult;
  const char *zResult;

  if( argc<2 ){
    return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
  }
  tclInterp = (Tcl_Interp *)ctx;
  if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
    Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
    return TH_ERROR;
  }
  Tcl_Preserve((ClientData)tclInterp);
  if( argc==2 ){
    objPtr = Tcl_NewStringObj(argv[1], argl[1]);
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
    Tcl_DecrRefCount(objPtr);
  }else{

    USE_ARGV_TO_OBJV();
    COPY_ARGV_TO_OBJV();





    objPtr = Tcl_ConcatObj(objc, objv);
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
    Tcl_DecrRefCount(objPtr);
    FREE_ARGV_TO_OBJV();

  }
  if( rc==TCL_OK ){
    zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
  }else{
    zResult = getTclResult(tclInterp, &nResult);
  }

  Th_SetResult(interp, zResult, nResult);
  if( rc==TCL_OK ) Tcl_DecrRefCount(resultObjPtr);
  Tcl_Release((ClientData)tclInterp);
  return rc;
}

/*
** Syntax:
**
**   tclInvoke command ?arg ...?
................................................................................
  Th_Interp *interp,
  void *ctx,
  int argc,
  const char **argv,
  int *argl
){
  Tcl_Interp *tclInterp;
  Tcl_Command command;
  Tcl_CmdInfo cmdInfo;



  int rc;
  int nResult;
  const char *zResult;
  Tcl_Obj *objPtr;
  USE_ARGV_TO_OBJV();

  if( argc<2 ){
    return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
  }
  tclInterp = (Tcl_Interp *)ctx;
  if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
    Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
    return TH_ERROR;
  }
  Tcl_Preserve((ClientData)tclInterp);
  objPtr = Tcl_NewStringObj(argv[1], argl[1]);
  Tcl_IncrRefCount(objPtr);
  command = Tcl_GetCommandFromObj(tclInterp, objPtr);
  if( !command || Tcl_GetCommandInfoFromToken(command,&cmdInfo)==0 ){
    Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
    Tcl_DecrRefCount(objPtr);
    Tcl_Release((ClientData)tclInterp);
    return TH_ERROR;
  }
  Tcl_DecrRefCount(objPtr);
  COPY_ARGV_TO_OBJV();
  Tcl_ResetResult(tclInterp);
  rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
  FREE_ARGV_TO_OBJV();
  zResult = getTclResult(tclInterp, &nResult);



  Th_SetResult(interp, zResult, nResult);
  Tcl_Release((ClientData)tclInterp);
  return rc;
}

/*
** Syntax:
................................................................................
 */
static void Th1DeleteProc(
  ClientData clientData,
  Tcl_Interp *interp
){
  int i;
  Th_Interp *th1Interp = (Th_Interp *)clientData;
  if( !th1Interp ) return;
  /* Remove the Tcl integration commands. */
  for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
    Th_RenameCommand(th1Interp, aCommand[i].zName, -1, NULL, 0);
  }
}

/*
................................................................................
** Register the Tcl language commands with interpreter interp.
** Usually this is called soon after interpreter creation.
*/
int th_register_tcl(Th_Interp *interp){
  int i;
  Tcl_Interp *tclInterp = Tcl_CreateInterp();

  if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
    Th_ErrorMessage(interp,
        "Could not create Tcl interpreter", (const char *)"", 0);
    return TH_ERROR;
  }
  if( Tcl_Init(tclInterp)!=TCL_OK ){
    Th_ErrorMessage(interp,
        "Tcl initialization error:", Tcl_GetStringResult(tclInterp), -1);
    Tcl_DeleteInterp(tclInterp);
    return TH_ERROR;
  }
  /* Add the TH1 integration commands to Tcl. */
  Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
  Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
  Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
  /* Add the Tcl integration commands to TH1. */
  for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
    void *ctx = aCommand[i].pContext;
    /* Use Tcl interpreter for context? */
    if( !ctx ) ctx = tclInterp;
    Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
  }
  return TH_OK;
}

Added test/th1-tcl.test.















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
#
# Copyright (c) 2011 D. Richard Hipp
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the Simplified BSD License (also
# known as the "2-Clause License" or "FreeBSD License".)
#
# This program is distributed in the hope that it will be useful,
# but without any warranty; without even the implied warranty of
# merchantability or fitness for a particular purpose.
#
# Author contact information:
#   drh@hwaci.com
#   http://www.hwaci.com/drh/
#
############################################################################
#
# TH1/Tcl integration
#

set dir [file dirname [info script]]

###############################################################################

fossil test-th-render [file nativename [file join $dir th1-tcl1.txt]]

test th1-tcl-1 {[regexp -- {^\d+
\d+
\d+
via Tcl invoke
4
4
two words
one_word
three words now
\d+
two words
4
\d+
two words
4
\d+
one_word
three words now
$} [string map [list \r\n \n] $RESULT]]}

###############################################################################

fossil test-th-render [file nativename [file join $dir th1-tcl2.txt]]

test th1-tcl-2 {[regexp -- {^\d+
$} [string map [list \r\n \n] $RESULT]]}

###############################################################################

fossil test-th-render [file nativename [file join $dir th1-tcl3.txt]]

test th1-tcl-3 {$RESULT eq {<hr><p class="thmainError">ERROR:\
invalid command name &quot;bad_command&quot;</p>}}

###############################################################################

fossil test-th-render [file nativename [file join $dir th1-tcl4.txt]]

test th1-tcl-4 {$RESULT eq {<hr><p class="thmainError">ERROR:\
divide by zero</p>}}

###############################################################################

fossil test-th-render [file nativename [file join $dir th1-tcl5.txt]]

test th1-tcl-5 {$RESULT eq {<hr><p class="thmainError">ERROR:\
Tcl command not found: bad_command</p>}}

###############################################################################

fossil test-th-render [file nativename [file join $dir th1-tcl6.txt]]

test th1-tcl-6 {$RESULT eq {<hr><p class="thmainError">ERROR:\
no such command:  bad_command</p>}}

###############################################################################

fossil test-th-render [file nativename [file join $dir th1-tcl7.txt]]

test th1-tcl-7 {$RESULT eq {<hr><p class="thmainError">ERROR:\
syntax error in expression: &quot;2**0&quot;</p>}}

Added test/th1-tcl1.txt.























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
<th1>
  #
  # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
  # The corresponding test file executes this file using the test-th-render
  # Fossil command.
  #
  set channel stdout; tclInvoke set channel $channel
  proc doOut {msg} {puts $msg; puts \n}
  doOut [tclEval clock seconds]
  doOut [tclEval {set x [clock seconds]}]
  tclEval {puts $channel "[clock seconds]"}
  tclInvoke puts $channel "via Tcl invoke"
  doOut [tclExpr 2+2]
  doOut [tclExpr 2 + 2]
  doOut [tclInvoke set x "two words"]
  doOut [tclInvoke eval set y one_word]
  doOut [tclInvoke eval {set z "three words now"}]
  doOut [set x [tclEval {set x [clock seconds]}]]
  doOut [tclInvoke th1Eval {set y "two words"}]
  doOut [set z [tclInvoke th1Expr {2+2}]]
  doOut $x
  doOut $y
  doOut $z
  doOut [tclEval set x]
  doOut [tclEval set y]
  doOut [tclEval set z]
</th1>

Added test/th1-tcl2.txt.







































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
<th1>
  #
  # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
  # The corresponding test file executes this file using the test-th-render
  # Fossil command.
  #
  # NOTE: This test requires that the SQLite package be available for the Tcl
  #       interpreter that is linked to the Fossil executable.
  #
  tclInvoke set repository_name [repository 1]
  proc doOut {msg} {puts $msg; puts \n}
  doOut [tclEval {
    package require sqlite3
    sqlite3 db $repository_name
    set x [db eval {SELECT COUNT(*) FROM user;}]
    db close
    return $x
  }]
</th1>

Added test/th1-tcl3.txt.



















>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
<th1>
  #
  # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
  # The corresponding test file executes this file using the test-th-render
  # Fossil command.
  #
  proc doOut {msg} {puts $msg; puts \n}
  doOut [tclEval bad_command]
</th1>

Added test/th1-tcl4.txt.



















>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
<th1>
  #
  # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
  # The corresponding test file executes this file using the test-th-render
  # Fossil command.
  #
  proc doOut {msg} {puts $msg; puts \n}
  doOut [tclExpr 2/0]
</th1>

Added test/th1-tcl5.txt.



















>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
<th1>
  #
  # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
  # The corresponding test file executes this file using the test-th-render
  # Fossil command.
  #
  proc doOut {msg} {puts $msg; puts \n}
  doOut [tclInvoke bad_command]
</th1>

Added test/th1-tcl6.txt.



















>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
<th1>
  #
  # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
  # The corresponding test file executes this file using the test-th-render
  # Fossil command.
  #
  proc doOut {msg} {puts $msg; puts \n}
  doOut [tclEval th1Eval bad_command]
</th1>

Added test/th1-tcl7.txt.







































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
<th1>
  #
  # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
  # The corresponding test file executes this file using the test-th-render
  # Fossil command.
  #
  proc doOut {msg} {puts $msg; puts \n}

  #
  # BUGBUG: Attempting to divide by zero will crash TH1 with the error:
  #         "child killed: floating-point exception"
  #
  # doOut [tclEval th1Expr 2/0]

  #
  # NOTE: For now, just cause an expression syntax error.
  #
  doOut [tclEval th1Expr 2**0]
</th1>