Check-in [a87eaae301]
Not logged in
Home Timeline Branches Tags Tickets Wiki Login

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

Overview
Comment:Add 'tclReady' TH1 command, with tests. Adjust expected result for test 'th1-tcl-8'.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: a87eaae301b95749c63a26c65248b6333ff31f34
User & Date: mistachkin 2013-04-28 22:23:50.732
Context
2013-04-29
18:21
Add the hash-color-test webpage. check-in: 748f975345 user: drh tags: trunk
2013-04-28
22:23
Add 'tclReady' TH1 command, with tests. Adjust expected result for test 'th1-tcl-8'. check-in: a87eaae301 user: mistachkin tags: trunk
20:19
All ui pages (and their JSON equivalent) should handle filenames case-sensitive because they don't access the file system check-in: 4c5c96c9e0 user: jan.nijtmans tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Changes to src/th_main.c.
︙︙
312
313
314
315
316
317
318































319
320
321
322
323
324
325

  if( g.thTrace ){
    Th_Trace("[hasfeature %#h] => %d<br />\n", argl[1], zArg, rc);
  }
  Th_SetResultInt(interp, rc);
  return TH_OK;
}

































/*
** TH command:     anycap STRING
**
** Return true if the user has any one of the capabilities listed in STRING.
*/
static int anycapCmd(








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








312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356

  if( g.thTrace ){
    Th_Trace("[hasfeature %#h] => %d<br />\n", argl[1], zArg, rc);
  }
  Th_SetResultInt(interp, rc);
  return TH_OK;
}


/*
** TH command:     tclReady
**
** Return true if the fossil binary has the Tcl integration feature
** enabled and it is currently available for use by TH1 scripts.
**
*/
static int tclReadyCmd(
  Th_Interp *interp,
  void *p,
  int argc,
  const char **argv,
  int *argl
){
  int rc = 0;
  if( argc!=1 ){
    return Th_WrongNumArgs(interp, "tclReady");
  }
#if defined(FOSSIL_ENABLE_TCL)
  if( g.tcl.interp ){
    rc = 1;
  }
#endif
  if( g.thTrace ){
    Th_Trace("[tclReady] => %d<br />\n", rc);
  }
  Th_SetResultInt(interp, rc);
  return TH_OK;
}


/*
** TH command:     anycap STRING
**
** Return true if the user has any one of the capabilities listed in STRING.
*/
static int anycapCmd(
︙︙
732
733
734
735
736
737
738

739
740
741
742
743
744
745

    {"htmlize",       htmlizeCmd,           0},
    {"linecount",     linecntCmd,           0},
    {"puts",          putsCmd,              (void*)&aFlags[1]},
    {"query",         queryCmd,             0},
    {"randhex",       randhexCmd,           0},
    {"regexp",        regexpCmd,            0},
    {"repository",    repositoryCmd,        0},

    {"stime",         stimeCmd,             0},
    {"utime",         utimeCmd,             0},
    {"wiki",          wikiCmd,              (void*)&aFlags[0]},
    {0, 0, 0}
  };
  if( needConfig ){
    /*








>








763
764
765
766
767
768
769
770
771
772
773
774
775
776
777

    {"htmlize",       htmlizeCmd,           0},
    {"linecount",     linecntCmd,           0},
    {"puts",          putsCmd,              (void*)&aFlags[1]},
    {"query",         queryCmd,             0},
    {"randhex",       randhexCmd,           0},
    {"regexp",        regexpCmd,            0},
    {"repository",    repositoryCmd,        0},
    {"tclReady",      tclReadyCmd,          0},
    {"stime",         stimeCmd,             0},
    {"utime",         utimeCmd,             0},
    {"wiki",          wikiCmd,              (void*)&aFlags[0]},
    {0, 0, 0}
  };
  if( needConfig ){
    /*
︙︙
Changes to src/th_tcl.c.
︙︙
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402

    return rc;
  }
  Tcl_Preserve((ClientData)tclInterp);
#if !defined(USE_TCL_EVALOBJV)
  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;
  }
  if( !cmdInfo.objProc ){
    Th_ErrorMessage(interp, "cannot invoke Tcl command:", argv[1], argl[1]);








|








388
389
390
391
392
393
394
395
396
397
398
399
400
401
402

    return rc;
  }
  Tcl_Preserve((ClientData)tclInterp);
#if !defined(USE_TCL_EVALOBJV)
  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;
  }
  if( !cmdInfo.objProc ){
    Th_ErrorMessage(interp, "cannot invoke Tcl command:", argv[1], argl[1]);
︙︙
Changes to test/th1-tcl.test.
︙︙
32
33
34
35
36
37
38
39


40
41
42
43
44
45
46


set env(TH1_ENABLE_TCL) 1; # Tcl integration must be enabled for this test.

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

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








|
>
>








32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48


set env(TH1_ENABLE_TCL) 1; # Tcl integration must be enabled for this test.

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

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

test th1-tcl-1 {[regexp -- {^tclReady\(before\) = 0
tclReady\(after\) = 1
\d+
\d+
\d+
via Tcl invoke
4
4
two words
one_word
︙︙
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116

syntax error in expression: &quot;2**0&quot;</p>}}

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

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

test th1-tcl-8 {$RESULT eq {<hr><p class="thmainError">ERROR:\
Cannot invoke Tcl command: tailcall</p>} || $RESULT eq {<hr><p\
class="thmainError">ERROR: tailcall can only be called from a proc or\
lambda</p>}}

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

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

test th1-tcl-9 {[string trim $RESULT] eq [list [file tail $fossilexe] 2 \
[list test-th-render [file nativename [file join $dir th1-tcl9.txt]]]]}








|










102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118

syntax error in expression: &quot;2**0&quot;</p>}}

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

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

test th1-tcl-8 {$RESULT eq {<hr><p class="thmainError">ERROR:\
cannot invoke Tcl command: tailcall</p>} || $RESULT eq {<hr><p\
class="thmainError">ERROR: tailcall can only be called from a proc or\
lambda</p>}}

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

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

test th1-tcl-9 {[string trim $RESULT] eq [list [file tail $fossilexe] 2 \
[list test-th-render [file nativename [file join $dir th1-tcl9.txt]]]]}
Changes to test/th1-tcl1.txt. 
1
2
3
4
5
6


7
8
9
10
11
12
13
14
15

<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"]







>
>

|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

<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 "tclReady(before) = [tclReady]"
  set channel stdout; tclInvoke set channel $channel
  doOut "tclReady(after) = [tclReady]"
  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"]
︙︙
Fossil version [1205ec86cb] 2025-04-30 16:57:32