Fossil SCM

Add 'tclReady' TH1 command, with tests. Adjust expected result for test 'th1-tcl-8'.

mistachkin 2013-04-28 22:23 trunk
Commit a87eaae301b95749c63a26c65248b6333ff31f34
Parent 4c5c96c9e01f486…
4 files changed +32 +1 -1 +4 -2 +3 -1
~ src/th_main.c ~ src/th_tcl.c ~ test/th1-tcl.test ~ test/th1-tcl1.txt
M src/th_main.c
+32
--- src/th_main.c
+++ src/th_main.c
@@ -314,10 +314,41 @@
314314
 }
315315
 Th_SetResultInt(interp, rc);
316316
 return TH_OK;
317317
 }
318318
319
+
320
+/*
321
+** TH command: tclReady
322
+**
323
+** Return true if the fossil binary has the Tcl integration feature
324
+** enabled and it is currently available for use by TH1 scripts.
325
+**
326
+*/
327
+static int tclReadyCmd(
328
+ Th_Interp *interp,
329
+ void *p,
330
+ int argc,
331
+ const char **argv,
332
+ int *argl
333
+){
334
+ int rc = 0;
335
+ if( argc!=1 ){
336
+ return Th_WrongNumArgs(interp, "tclReady");
337
+ }
338
+#if defined(FOSSIL_ENABLE_TCL)
339
+ if( g.tcl.interp ){
340
+ rc = 1;
341
+ }
342
+#endif
343
+ if( g.thTrace ){
344
+ Th_Trace("[tclReady] => %d<br />\n", rc);
345
+ }
346
+ Th_SetResultInt(interp, rc);
347
+ return TH_OK;
348
+}
349
+
319350
320351
 /*
321352
 ** TH command: anycap STRING
322353
 **
323354
 ** Return true if the user has any one of the capabilities listed in STRING.
@@ -734,10 +765,11 @@
734765
 {"puts", putsCmd, (void*)&aFlags[1]},
735766
 {"query", queryCmd, 0},
736767
 {"randhex", randhexCmd, 0},
737768
 {"regexp", regexpCmd, 0},
738769
 {"repository", repositoryCmd, 0},
770
+ {"tclReady", tclReadyCmd, 0},
739771
 {"stime", stimeCmd, 0},
740772
 {"utime", utimeCmd, 0},
741773
 {"wiki", wikiCmd, (void*)&aFlags[0]},
742774
 {0, 0, 0}
743775
 };
744776
--- src/th_main.c
+++ src/th_main.c
@@ -314,10 +314,41 @@
314 }
315 Th_SetResultInt(interp, rc);
316 return TH_OK;
317 }
318
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
319
320 /*
321 ** TH command: anycap STRING
322 **
323 ** Return true if the user has any one of the capabilities listed in STRING.
@@ -734,10 +765,11 @@
734 {"puts", putsCmd, (void*)&aFlags[1]},
735 {"query", queryCmd, 0},
736 {"randhex", randhexCmd, 0},
737 {"regexp", regexpCmd, 0},
738 {"repository", repositoryCmd, 0},
 
739 {"stime", stimeCmd, 0},
740 {"utime", utimeCmd, 0},
741 {"wiki", wikiCmd, (void*)&aFlags[0]},
742 {0, 0, 0}
743 };
744
--- src/th_main.c
+++ src/th_main.c
@@ -314,10 +314,41 @@
314 }
315 Th_SetResultInt(interp, rc);
316 return TH_OK;
317 }
318
319
320 /*
321 ** TH command: tclReady
322 **
323 ** Return true if the fossil binary has the Tcl integration feature
324 ** enabled and it is currently available for use by TH1 scripts.
325 **
326 */
327 static int tclReadyCmd(
328 Th_Interp *interp,
329 void *p,
330 int argc,
331 const char **argv,
332 int *argl
333 ){
334 int rc = 0;
335 if( argc!=1 ){
336 return Th_WrongNumArgs(interp, "tclReady");
337 }
338 #if defined(FOSSIL_ENABLE_TCL)
339 if( g.tcl.interp ){
340 rc = 1;
341 }
342 #endif
343 if( g.thTrace ){
344 Th_Trace("[tclReady] => %d<br />\n", rc);
345 }
346 Th_SetResultInt(interp, rc);
347 return TH_OK;
348 }
349
350
351 /*
352 ** TH command: anycap STRING
353 **
354 ** Return true if the user has any one of the capabilities listed in STRING.
@@ -734,10 +765,11 @@
765 {"puts", putsCmd, (void*)&aFlags[1]},
766 {"query", queryCmd, 0},
767 {"randhex", randhexCmd, 0},
768 {"regexp", regexpCmd, 0},
769 {"repository", repositoryCmd, 0},
770 {"tclReady", tclReadyCmd, 0},
771 {"stime", stimeCmd, 0},
772 {"utime", utimeCmd, 0},
773 {"wiki", wikiCmd, (void*)&aFlags[0]},
774 {0, 0, 0}
775 };
776
M src/th_tcl.c
+1 -1
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -390,11 +390,11 @@
390390
 Tcl_Preserve((ClientData)tclInterp);
391391
 #if !defined(USE_TCL_EVALOBJV)
392392
 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
393393
 Tcl_IncrRefCount(objPtr);
394394
 command = Tcl_GetCommandFromObj(tclInterp, objPtr);
395
- if( !command || Tcl_GetCommandInfoFromToken(command,&cmdInfo)==0 ){
395
+ if( !command || Tcl_GetCommandInfoFromToken(command, &cmdInfo)==0 ){
396396
 Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
397397
 Tcl_DecrRefCount(objPtr);
398398
 Tcl_Release((ClientData)tclInterp);
399399
 return TH_ERROR;
400400
 }
401401
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -390,11 +390,11 @@
390 Tcl_Preserve((ClientData)tclInterp);
391 #if !defined(USE_TCL_EVALOBJV)
392 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
393 Tcl_IncrRefCount(objPtr);
394 command = Tcl_GetCommandFromObj(tclInterp, objPtr);
395 if( !command || Tcl_GetCommandInfoFromToken(command,&cmdInfo)==0 ){
396 Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
397 Tcl_DecrRefCount(objPtr);
398 Tcl_Release((ClientData)tclInterp);
399 return TH_ERROR;
400 }
401
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -390,11 +390,11 @@
390 Tcl_Preserve((ClientData)tclInterp);
391 #if !defined(USE_TCL_EVALOBJV)
392 objPtr = Tcl_NewStringObj(argv[1], argl[1]);
393 Tcl_IncrRefCount(objPtr);
394 command = Tcl_GetCommandFromObj(tclInterp, objPtr);
395 if( !command || Tcl_GetCommandInfoFromToken(command, &cmdInfo)==0 ){
396 Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
397 Tcl_DecrRefCount(objPtr);
398 Tcl_Release((ClientData)tclInterp);
399 return TH_ERROR;
400 }
401
M test/th1-tcl.test
+4 -2
--- test/th1-tcl.test
+++ test/th1-tcl.test
@@ -34,11 +34,13 @@
3434
3535
 ###############################################################################
3636
3737
 fossil test-th-render [file nativename [file join $dir th1-tcl1.txt]]
3838
39
-test th1-tcl-1 {[regexp -- {^\d+
39
+test th1-tcl-1 {[regexp -- {^tclReady\(before\) = 0
40
+tclReady\(after\) = 1
41
+\d+
4042
 \d+
4143
 \d+
4244
 via Tcl invoke
4345
 4
4446
 4
@@ -102,15 +104,15 @@
102104
 ###############################################################################
103105
104106
 fossil test-th-render [file nativename [file join $dir th1-tcl8.txt]]
105107
106108
 test th1-tcl-8 {$RESULT eq {<hr><p class="thmainError">ERROR:\
107
-Cannot invoke Tcl command: tailcall</p>} || $RESULT eq {<hr><p\
109
+cannot invoke Tcl command: tailcall</p>} || $RESULT eq {<hr><p\
108110
 class="thmainError">ERROR: tailcall can only be called from a proc or\
109111
 lambda</p>}}
110112
111113
 ###############################################################################
112114
113115
 fossil test-th-render [file nativename [file join $dir th1-tcl9.txt]]
114116
115117
 test th1-tcl-9 {[string trim $RESULT] eq [list [file tail $fossilexe] 2 \
116118
 [list test-th-render [file nativename [file join $dir th1-tcl9.txt]]]]}
117119
--- test/th1-tcl.test
+++ test/th1-tcl.test
@@ -34,11 +34,13 @@
34
35 ###############################################################################
36
37 fossil test-th-render [file nativename [file join $dir th1-tcl1.txt]]
38
39 test th1-tcl-1 {[regexp -- {^\d+
 
 
40 \d+
41 \d+
42 via Tcl invoke
43 4
44 4
@@ -102,15 +104,15 @@
102 ###############################################################################
103
104 fossil test-th-render [file nativename [file join $dir th1-tcl8.txt]]
105
106 test th1-tcl-8 {$RESULT eq {<hr><p class="thmainError">ERROR:\
107 Cannot invoke Tcl command: tailcall</p>} || $RESULT eq {<hr><p\
108 class="thmainError">ERROR: tailcall can only be called from a proc or\
109 lambda</p>}}
110
111 ###############################################################################
112
113 fossil test-th-render [file nativename [file join $dir th1-tcl9.txt]]
114
115 test th1-tcl-9 {[string trim $RESULT] eq [list [file tail $fossilexe] 2 \
116 [list test-th-render [file nativename [file join $dir th1-tcl9.txt]]]]}
117
--- test/th1-tcl.test
+++ test/th1-tcl.test
@@ -34,11 +34,13 @@
34
35 ###############################################################################
36
37 fossil test-th-render [file nativename [file join $dir th1-tcl1.txt]]
38
39 test th1-tcl-1 {[regexp -- {^tclReady\(before\) = 0
40 tclReady\(after\) = 1
41 \d+
42 \d+
43 \d+
44 via Tcl invoke
45 4
46 4
@@ -102,15 +104,15 @@
104 ###############################################################################
105
106 fossil test-th-render [file nativename [file join $dir th1-tcl8.txt]]
107
108 test th1-tcl-8 {$RESULT eq {<hr><p class="thmainError">ERROR:\
109 cannot invoke Tcl command: tailcall</p>} || $RESULT eq {<hr><p\
110 class="thmainError">ERROR: tailcall can only be called from a proc or\
111 lambda</p>}}
112
113 ###############################################################################
114
115 fossil test-th-render [file nativename [file join $dir th1-tcl9.txt]]
116
117 test th1-tcl-9 {[string trim $RESULT] eq [list [file tail $fossilexe] 2 \
118 [list test-th-render [file nativename [file join $dir th1-tcl9.txt]]]]}
119
M test/th1-tcl1.txt
+3 -1
--- test/th1-tcl1.txt
+++ test/th1-tcl1.txt
@@ -2,12 +2,14 @@
22
 #
33
 # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
44
 # The corresponding test file executes this file using the test-th-render
55
 # Fossil command.
66
 #
7
- set channel stdout; tclInvoke set channel $channel
87
 proc doOut {msg} {puts $msg; puts \n}
8
+ doOut "tclReady(before) = [tclReady]"
9
+ set channel stdout; tclInvoke set channel $channel
10
+ doOut "tclReady(after) = [tclReady]"
911
 doOut [tclEval clock seconds]
1012
 doOut [tclEval {set x [clock seconds]}]
1113
 tclEval {puts $channel "[clock seconds]"}
1214
 tclInvoke puts $channel "via Tcl invoke"
1315
 doOut [tclExpr 2+2]
1416
--- test/th1-tcl1.txt
+++ test/th1-tcl1.txt
@@ -2,12 +2,14 @@
2 #
3 # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
4 # The corresponding test file executes this file using the test-th-render
5 # Fossil command.
6 #
7 set channel stdout; tclInvoke set channel $channel
8 proc doOut {msg} {puts $msg; puts \n}
 
 
 
9 doOut [tclEval clock seconds]
10 doOut [tclEval {set x [clock seconds]}]
11 tclEval {puts $channel "[clock seconds]"}
12 tclInvoke puts $channel "via Tcl invoke"
13 doOut [tclExpr 2+2]
14
--- test/th1-tcl1.txt
+++ test/th1-tcl1.txt
@@ -2,12 +2,14 @@
2 #
3 # This is a "TH1 fragment" used to test the Tcl integration features of TH1.
4 # The corresponding test file executes this file using the test-th-render
5 # Fossil command.
6 #
 
7 proc doOut {msg} {puts $msg; puts \n}
8 doOut "tclReady(before) = [tclReady]"
9 set channel stdout; tclInvoke set channel $channel
10 doOut "tclReady(after) = [tclReady]"
11 doOut [tclEval clock seconds]
12 doOut [tclEval {set x [clock seconds]}]
13 tclEval {puts $channel "[clock seconds]"}
14 tclInvoke puts $channel "via Tcl invoke"
15 doOut [tclExpr 2+2]
16

Keyboard Shortcuts

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