Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch wapptest Excluding Merge-Ins
This is equivalent to a diff from d71f8bbc4e to d805fc0cf1
|
2019-04-11
| ||
| 19:07 | Add the test/wapptest.tcl script, an alternative to releasetest.tcl that uses wapp to provide the user-interface. (check-in: edd87cd606 user: dan tags: trunk) | |
| 19:04 | Merge trunk changes into this branch. (Closed-Leaf check-in: d805fc0cf1 user: dan tags: wapptest) | |
| 19:03 | Further tweaks to wapptest.tcl. Add the ability to run the extra (n)debug tests that releasetest.tcl runs. (check-in: ec9c4f6d8d user: dan tags: wapptest) | |
| 17:06 | Remove the vfslog.c extension from the testfixture target in main.mk, as that extension has no TCL bindings and is inaccessible. (check-in: d71f8bbc4e user: drh tags: trunk) | |
| 16:54 | Fix RBU so that it does not write rows that should be excluded into partial indexes (corrupting the database). (check-in: 31eb27f438 user: dan tags: trunk) | |
Changes to Makefile.in.
1368 1368 $(LTLINK) $(TOP)/tool/loadfts.c libsqlite3.la -o $@ $(TLIBS) 1369 1369 1370 1370 # This target will fail if the SQLite amalgamation contains any exported 1371 1371 # symbols that do not begin with "sqlite3_". It is run as part of the 1372 1372 # releasetest.tcl script. 1373 1373 # 1374 1374 VALIDIDS=' sqlite3(changeset|changegroup|session)?_' 1375 -checksymbols: sqlite3.lo 1376 - nm -g --defined-only sqlite3.lo | egrep -v $(VALIDIDS); test $$? -ne 0 1375 +checksymbols: sqlite3.o 1376 + nm -g --defined-only sqlite3.o 1377 + nm -g --defined-only sqlite3.o | egrep -v $(VALIDIDS); test $$? -ne 0 1377 1378 echo '0 errors out of 1 tests' 1378 1379 1379 1380 # Build the amalgamation-autoconf package. The amalamgation-tarball target builds 1380 1381 # a tarball named for the version number. Ex: sqlite-autoconf-3110000.tar.gz. 1381 1382 # The snapshot-tarball target builds a tarball named by the SHA1 hash 1382 1383 # 1383 1384 amalgamation-tarball: sqlite3.c
Added test/releasetest_data.tcl.
1 + 2 +# This file contains Configuration data used by "wapptest.tcl" and 3 +# "releasetest.tcl". 4 +# 5 + 6 +# Omit comments (text between # and \n) in a long multi-line string. 7 +# 8 +proc strip_comments {in} { 9 + regsub -all {#[^\n]*\n} $in {} out 10 + return $out 11 +} 12 + 13 +array set ::Configs [strip_comments { 14 + "Default" { 15 + -O2 16 + --disable-amalgamation --disable-shared 17 + --enable-session 18 + -DSQLITE_ENABLE_DESERIALIZE 19 + } 20 + "Sanitize" { 21 + CC=clang -fsanitize=undefined 22 + -DSQLITE_ENABLE_STAT4 23 + --enable-session 24 + } 25 + "Stdcall" { 26 + -DUSE_STDCALL=1 27 + -O2 28 + } 29 + "Have-Not" { 30 + # The "Have-Not" configuration sets all possible -UHAVE_feature options 31 + # in order to verify that the code works even on platforms that lack 32 + # these support services. 33 + -DHAVE_FDATASYNC=0 34 + -DHAVE_GMTIME_R=0 35 + -DHAVE_ISNAN=0 36 + -DHAVE_LOCALTIME_R=0 37 + -DHAVE_LOCALTIME_S=0 38 + -DHAVE_MALLOC_USABLE_SIZE=0 39 + -DHAVE_STRCHRNUL=0 40 + -DHAVE_USLEEP=0 41 + -DHAVE_UTIME=0 42 + } 43 + "Unlock-Notify" { 44 + -O2 45 + -DSQLITE_ENABLE_UNLOCK_NOTIFY 46 + -DSQLITE_THREADSAFE 47 + -DSQLITE_TCL_DEFAULT_FULLMUTEX=1 48 + } 49 + "User-Auth" { 50 + -O2 51 + -DSQLITE_USER_AUTHENTICATION=1 52 + } 53 + "Secure-Delete" { 54 + -O2 55 + -DSQLITE_SECURE_DELETE=1 56 + -DSQLITE_SOUNDEX=1 57 + } 58 + "Update-Delete-Limit" { 59 + -O2 60 + -DSQLITE_DEFAULT_FILE_FORMAT=4 61 + -DSQLITE_ENABLE_UPDATE_DELETE_LIMIT=1 62 + -DSQLITE_ENABLE_STMT_SCANSTATUS 63 + -DSQLITE_LIKE_DOESNT_MATCH_BLOBS 64 + -DSQLITE_ENABLE_CURSOR_HINTS 65 + --enable-json1 66 + } 67 + "Check-Symbols" { 68 + -DSQLITE_MEMDEBUG=1 69 + -DSQLITE_ENABLE_FTS3_PARENTHESIS=1 70 + -DSQLITE_ENABLE_FTS3=1 71 + -DSQLITE_ENABLE_RTREE=1 72 + -DSQLITE_ENABLE_MEMSYS5=1 73 + -DSQLITE_ENABLE_MEMSYS3=1 74 + -DSQLITE_ENABLE_COLUMN_METADATA=1 75 + -DSQLITE_ENABLE_UPDATE_DELETE_LIMIT=1 76 + -DSQLITE_SECURE_DELETE=1 77 + -DSQLITE_SOUNDEX=1 78 + -DSQLITE_ENABLE_ATOMIC_WRITE=1 79 + -DSQLITE_ENABLE_MEMORY_MANAGEMENT=1 80 + -DSQLITE_ENABLE_OVERSIZE_CELL_CHECK=1 81 + -DSQLITE_ENABLE_STAT4 82 + -DSQLITE_ENABLE_STMT_SCANSTATUS 83 + --enable-json1 --enable-fts5 --enable-session 84 + } 85 + "Debug-One" { 86 + --disable-shared 87 + -O2 -funsigned-char 88 + -DSQLITE_DEBUG=1 89 + -DSQLITE_MEMDEBUG=1 90 + -DSQLITE_MUTEX_NOOP=1 91 + -DSQLITE_TCL_DEFAULT_FULLMUTEX=1 92 + -DSQLITE_ENABLE_FTS3=1 93 + -DSQLITE_ENABLE_RTREE=1 94 + -DSQLITE_ENABLE_MEMSYS5=1 95 + -DSQLITE_ENABLE_COLUMN_METADATA=1 96 + -DSQLITE_ENABLE_STAT4 97 + -DSQLITE_ENABLE_HIDDEN_COLUMNS 98 + -DSQLITE_MAX_ATTACHED=125 99 + -DSQLITE_MUTATION_TEST 100 + --enable-fts5 --enable-json1 101 + } 102 + "Fast-One" { 103 + -O6 104 + -DSQLITE_ENABLE_FTS4=1 105 + -DSQLITE_ENABLE_RTREE=1 106 + -DSQLITE_ENABLE_STAT4 107 + -DSQLITE_ENABLE_RBU 108 + -DSQLITE_MAX_ATTACHED=125 109 + -DLONGDOUBLE_TYPE=double 110 + --enable-session 111 + } 112 + "Device-One" { 113 + -O2 114 + -DSQLITE_DEBUG=1 115 + -DSQLITE_DEFAULT_AUTOVACUUM=1 116 + -DSQLITE_DEFAULT_CACHE_SIZE=64 117 + -DSQLITE_DEFAULT_PAGE_SIZE=1024 118 + -DSQLITE_DEFAULT_TEMP_CACHE_SIZE=32 119 + -DSQLITE_DISABLE_LFS=1 120 + -DSQLITE_ENABLE_ATOMIC_WRITE=1 121 + -DSQLITE_ENABLE_IOTRACE=1 122 + -DSQLITE_ENABLE_MEMORY_MANAGEMENT=1 123 + -DSQLITE_MAX_PAGE_SIZE=4096 124 + -DSQLITE_OMIT_LOAD_EXTENSION=1 125 + -DSQLITE_OMIT_PROGRESS_CALLBACK=1 126 + -DSQLITE_OMIT_VIRTUALTABLE=1 127 + -DSQLITE_ENABLE_HIDDEN_COLUMNS 128 + -DSQLITE_TEMP_STORE=3 129 + --enable-json1 130 + } 131 + "Device-Two" { 132 + -DSQLITE_4_BYTE_ALIGNED_MALLOC=1 133 + -DSQLITE_DEFAULT_AUTOVACUUM=1 134 + -DSQLITE_DEFAULT_CACHE_SIZE=1000 135 + -DSQLITE_DEFAULT_LOCKING_MODE=0 136 + -DSQLITE_DEFAULT_PAGE_SIZE=1024 137 + -DSQLITE_DEFAULT_TEMP_CACHE_SIZE=1000 138 + -DSQLITE_DISABLE_LFS=1 139 + -DSQLITE_ENABLE_FTS3=1 140 + -DSQLITE_ENABLE_MEMORY_MANAGEMENT=1 141 + -DSQLITE_ENABLE_RTREE=1 142 + -DSQLITE_MAX_COMPOUND_SELECT=50 143 + -DSQLITE_MAX_PAGE_SIZE=32768 144 + -DSQLITE_OMIT_TRACE=1 145 + -DSQLITE_TEMP_STORE=3 146 + -DSQLITE_THREADSAFE=2 147 + -DSQLITE_ENABLE_DESERIALIZE=1 148 + --enable-json1 --enable-fts5 --enable-session 149 + } 150 + "Locking-Style" { 151 + -O2 152 + -DSQLITE_ENABLE_LOCKING_STYLE=1 153 + } 154 + "Apple" { 155 + -Os 156 + -DHAVE_GMTIME_R=1 157 + -DHAVE_ISNAN=1 158 + -DHAVE_LOCALTIME_R=1 159 + -DHAVE_PREAD=1 160 + -DHAVE_PWRITE=1 161 + -DHAVE_USLEEP=1 162 + -DHAVE_USLEEP=1 163 + -DHAVE_UTIME=1 164 + -DSQLITE_DEFAULT_CACHE_SIZE=1000 165 + -DSQLITE_DEFAULT_CKPTFULLFSYNC=1 166 + -DSQLITE_DEFAULT_MEMSTATUS=1 167 + -DSQLITE_DEFAULT_PAGE_SIZE=1024 168 + -DSQLITE_DISABLE_PAGECACHE_OVERFLOW_STATS=1 169 + -DSQLITE_ENABLE_API_ARMOR=1 170 + -DSQLITE_ENABLE_AUTO_PROFILE=1 171 + -DSQLITE_ENABLE_FLOCKTIMEOUT=1 172 + -DSQLITE_ENABLE_FTS3=1 173 + -DSQLITE_ENABLE_FTS3_PARENTHESIS=1 174 + -DSQLITE_ENABLE_FTS3_TOKENIZER=1 175 + if:os=="Darwin" -DSQLITE_ENABLE_LOCKING_STYLE=1 176 + -DSQLITE_ENABLE_PERSIST_WAL=1 177 + -DSQLITE_ENABLE_PURGEABLE_PCACHE=1 178 + -DSQLITE_ENABLE_RTREE=1 179 + -DSQLITE_ENABLE_SNAPSHOT=1 180 + # -DSQLITE_ENABLE_SQLLOG=1 181 + -DSQLITE_ENABLE_UPDATE_DELETE_LIMIT=1 182 + -DSQLITE_MAX_LENGTH=2147483645 183 + -DSQLITE_MAX_VARIABLE_NUMBER=500000 184 + # -DSQLITE_MEMDEBUG=1 185 + -DSQLITE_NO_SYNC=1 186 + -DSQLITE_OMIT_AUTORESET=1 187 + -DSQLITE_OMIT_LOAD_EXTENSION=1 188 + -DSQLITE_PREFER_PROXY_LOCKING=1 189 + -DSQLITE_SERIES_CONSTRAINT_VERIFY=1 190 + -DSQLITE_THREADSAFE=2 191 + -DSQLITE_USE_URI=1 192 + -DSQLITE_WRITE_WALFRAME_PREBUFFERED=1 193 + -DUSE_GUARDED_FD=1 194 + -DUSE_PREAD=1 195 + --enable-json1 --enable-fts5 196 + } 197 + "Extra-Robustness" { 198 + -DSQLITE_ENABLE_OVERSIZE_CELL_CHECK=1 199 + -DSQLITE_MAX_ATTACHED=62 200 + } 201 + "Devkit" { 202 + -DSQLITE_DEFAULT_FILE_FORMAT=4 203 + -DSQLITE_MAX_ATTACHED=30 204 + -DSQLITE_ENABLE_COLUMN_METADATA 205 + -DSQLITE_ENABLE_FTS4 206 + -DSQLITE_ENABLE_FTS5 207 + -DSQLITE_ENABLE_FTS4_PARENTHESIS 208 + -DSQLITE_DISABLE_FTS4_DEFERRED 209 + -DSQLITE_ENABLE_RTREE 210 + --enable-json1 --enable-fts5 211 + } 212 + "No-lookaside" { 213 + -DSQLITE_TEST_REALLOC_STRESS=1 214 + -DSQLITE_OMIT_LOOKASIDE=1 215 + -DHAVE_USLEEP=1 216 + } 217 + "Valgrind" { 218 + -DSQLITE_ENABLE_STAT4 219 + -DSQLITE_ENABLE_FTS4 220 + -DSQLITE_ENABLE_RTREE 221 + -DSQLITE_ENABLE_HIDDEN_COLUMNS 222 + --enable-json1 223 + } 224 + 225 + # The next group of configurations are used only by the 226 + # Failure-Detection platform. They are all the same, but we need 227 + # different names for them all so that they results appear in separate 228 + # subdirectories. 229 + # 230 + Fail0 {-O0} 231 + Fail2 {-O0} 232 + Fail3 {-O0} 233 + Fail4 {-O0} 234 + FuzzFail1 {-O0} 235 + FuzzFail2 {-O0} 236 +}] 237 + 238 +array set ::Platforms [strip_comments { 239 + Linux-x86_64 { 240 + "Check-Symbols" checksymbols 241 + "Fast-One" "fuzztest test" 242 + "Debug-One" "mptest test" 243 + "Have-Not" test 244 + "Secure-Delete" test 245 + "Unlock-Notify" "QUICKTEST_INCLUDE=notify2.test test" 246 + "User-Auth" tcltest 247 + "Update-Delete-Limit" test 248 + "Extra-Robustness" test 249 + "Device-Two" test 250 + "No-lookaside" test 251 + "Devkit" test 252 + "Apple" test 253 + "Sanitize" {QUICKTEST_OMIT=func4.test,nan.test test} 254 + "Device-One" fulltest 255 + "Default" "threadtest fulltest" 256 + "Valgrind" valgrindtest 257 + } 258 + Linux-i686 { 259 + "Devkit" test 260 + "Have-Not" test 261 + "Unlock-Notify" "QUICKTEST_INCLUDE=notify2.test test" 262 + "Device-One" test 263 + "Device-Two" test 264 + "Default" "threadtest fulltest" 265 + } 266 + Darwin-i386 { 267 + "Locking-Style" "mptest test" 268 + "Have-Not" test 269 + "Apple" "threadtest fulltest" 270 + } 271 + Darwin-x86_64 { 272 + "Locking-Style" "mptest test" 273 + "Have-Not" test 274 + "Apple" "threadtest fulltest" 275 + } 276 + "Windows NT-intel" { 277 + "Stdcall" test 278 + "Have-Not" test 279 + "Default" "mptest fulltestonly" 280 + } 281 + "Windows NT-amd64" { 282 + "Stdcall" test 283 + "Have-Not" test 284 + "Default" "mptest fulltestonly" 285 + } 286 + 287 + # The Failure-Detection platform runs various tests that deliberately 288 + # fail. This is used as a test of this script to verify that this script 289 + # correctly identifies failures. 290 + # 291 + Failure-Detection { 292 + Fail0 "TEST_FAILURE=0 test" 293 + Sanitize "TEST_FAILURE=1 test" 294 + Fail2 "TEST_FAILURE=2 valgrindtest" 295 + Fail3 "TEST_FAILURE=3 valgrindtest" 296 + Fail4 "TEST_FAILURE=4 test" 297 + FuzzFail1 "TEST_FAILURE=5 test" 298 + FuzzFail2 "TEST_FAILURE=5 valgrindtest" 299 + } 300 +}] 301 + 302 +proc make_test_suite {msvc withtcl name testtarget config} { 303 + 304 + # Tcl variable $opts is used to build up the value used to set the 305 + # OPTS Makefile variable. Variable $cflags holds the value for 306 + # CFLAGS. The makefile will pass OPTS to both gcc and lemon, but 307 + # CFLAGS is only passed to gcc. 308 + # 309 + set makeOpts "" 310 + set cflags [expr {$msvc ? "-Zi" : "-g"}] 311 + set opts "" 312 + set title ${name}($testtarget) 313 + set configOpts $withtcl 314 + set skip 0 315 + 316 + regsub -all {#[^\n]*\n} $config \n config 317 + foreach arg $config { 318 + if {$skip} { 319 + set skip 0 320 + continue 321 + } 322 + if {[regexp {^-[UD]} $arg]} { 323 + lappend opts $arg 324 + } elseif {[regexp {^[A-Z]+=} $arg]} { 325 + lappend testtarget $arg 326 + } elseif {[regexp {^if:([a-z]+)(.*)} $arg all key tail]} { 327 + # Arguments of the form 'if:os=="Linux"' will cause the subsequent 328 + # argument to be skipped if the $tcl_platform(os) is not "Linux", for 329 + # example... 330 + set skip [expr !(\$::tcl_platform($key)$tail)] 331 + } elseif {[regexp {^--(enable|disable)-} $arg]} { 332 + if {$msvc} { 333 + if {$arg eq "--disable-amalgamation"} { 334 + lappend makeOpts USE_AMALGAMATION=0 335 + continue 336 + } 337 + if {$arg eq "--disable-shared"} { 338 + lappend makeOpts USE_CRT_DLL=0 DYNAMIC_SHELL=0 339 + continue 340 + } 341 + if {$arg eq "--enable-fts5"} { 342 + lappend opts -DSQLITE_ENABLE_FTS5 343 + continue 344 + } 345 + if {$arg eq "--enable-json1"} { 346 + lappend opts -DSQLITE_ENABLE_JSON1 347 + continue 348 + } 349 + if {$arg eq "--enable-shared"} { 350 + lappend makeOpts USE_CRT_DLL=1 DYNAMIC_SHELL=1 351 + continue 352 + } 353 + } 354 + lappend configOpts $arg 355 + } else { 356 + if {$msvc} { 357 + if {$arg eq "-g"} { 358 + lappend cflags -Zi 359 + continue 360 + } 361 + if {[regexp -- {^-O(\d+)$} $arg all level]} then { 362 + lappend makeOpts OPTIMIZATIONS=$level 363 + continue 364 + } 365 + } 366 + lappend cflags $arg 367 + } 368 + } 369 + 370 + # Disable sync to make testing faster. 371 + # 372 + lappend opts -DSQLITE_NO_SYNC=1 373 + 374 + # Some configurations already set HAVE_USLEEP; in that case, skip it. 375 + # 376 + if {[lsearch -regexp $opts {^-DHAVE_USLEEP(?:=|$)}]==-1} { 377 + lappend opts -DHAVE_USLEEP=1 378 + } 379 + 380 + # Add the define for this platform. 381 + # 382 + if {$::tcl_platform(platform)=="windows"} { 383 + lappend opts -DSQLITE_OS_WIN=1 384 + } else { 385 + lappend opts -DSQLITE_OS_UNIX=1 386 + } 387 + 388 + # Set the sub-directory to use. 389 + # 390 + set dir [string tolower [string map {- _ " " _ "(" _ ")" _} $name]] 391 + 392 + # Join option lists into strings, using space as delimiter. 393 + # 394 + set makeOpts [join $makeOpts " "] 395 + set cflags [join $cflags " "] 396 + set opts [join $opts " "] 397 + 398 + return [list $title $dir $configOpts $testtarget $makeOpts $cflags $opts] 399 +} 400 + 401 +# Configuration verification: Check that each entry in the list of configs 402 +# specified for each platforms exists. 403 +# 404 +foreach {key value} [array get ::Platforms] { 405 + foreach {v t} $value { 406 + if {0==[info exists ::Configs($v)]} { 407 + puts stderr "No such configuration: \"$v\"" 408 + exit -1 409 + } 410 + } 411 +} 412 +
Added test/wapp.tcl.
1 +# Copyright (c) 2017 D. Richard Hipp 2 +# 3 +# This program is free software; you can redistribute it and/or 4 +# modify it under the terms of the Simplified BSD License (also 5 +# known as the "2-Clause License" or "FreeBSD License".) 6 +# 7 +# This program is distributed in the hope that it will be useful, 8 +# but without any warranty; without even the implied warranty of 9 +# merchantability or fitness for a particular purpose. 10 +# 11 +#--------------------------------------------------------------------------- 12 +# 13 +# Design rules: 14 +# 15 +# (1) All identifiers in the global namespace begin with "wapp" 16 +# 17 +# (2) Indentifiers intended for internal use only begin with "wappInt" 18 +# 19 +package require Tcl 8.6 20 + 21 +# Add text to the end of the HTTP reply. No interpretation or transformation 22 +# of the text is performs. The argument should be enclosed within {...} 23 +# 24 +proc wapp {txt} { 25 + global wapp 26 + dict append wapp .reply $txt 27 +} 28 + 29 +# Add text to the page under construction. Do no escaping on the text. 30 +# 31 +# Though "unsafe" in general, there are uses for this kind of thing. 32 +# For example, if you want to return the complete, unmodified content of 33 +# a file: 34 +# 35 +# set fd [open content.html rb] 36 +# wapp-unsafe [read $fd] 37 +# close $fd 38 +# 39 +# You could do the same thing using ordinary "wapp" instead of "wapp-unsafe". 40 +# The difference is that wapp-safety-check will complain about the misuse 41 +# of "wapp", but it assumes that the person who write "wapp-unsafe" understands 42 +# the risks. 43 +# 44 +# Though occasionally necessary, the use of this interface should be minimized. 45 +# 46 +proc wapp-unsafe {txt} { 47 + global wapp 48 + dict append wapp .reply $txt 49 +} 50 + 51 +# Add text to the end of the reply under construction. The following 52 +# substitutions are made: 53 +# 54 +# %html(...) Escape text for inclusion in HTML 55 +# %url(...) Escape text for use as a URL 56 +# %qp(...) Escape text for use as a URI query parameter 57 +# %string(...) Escape text for use within a JSON string 58 +# %unsafe(...) No transformations of the text 59 +# 60 +# The substitutions above terminate at the first ")" character. If the 61 +# text of the TCL string in ... contains ")" characters itself, use instead: 62 +# 63 +# %html%(...)% 64 +# %url%(...)% 65 +# %qp%(...)% 66 +# %string%(...)% 67 +# %unsafe%(...)% 68 +# 69 +# In other words, use "%(...)%" instead of "(...)" to include the TCL string 70 +# to substitute. 71 +# 72 +# The %unsafe substitution should be avoided whenever possible, obviously. 73 +# In addition to the substitutions above, the text also does backslash 74 +# escapes. 75 +# 76 +# The wapp-trim proc works the same as wapp-subst except that it also removes 77 +# whitespace from the left margin, so that the generated HTML/CSS/Javascript 78 +# does not appear to be indented when delivered to the client web browser. 79 +# 80 +if {$tcl_version>=8.7} { 81 + proc wapp-subst {txt} { 82 + global wapp 83 + regsub -all -command \ 84 + {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt wappInt-enc txt 85 + dict append wapp .reply [subst -novariables -nocommand $txt] 86 + } 87 + proc wapp-trim {txt} { 88 + global wapp 89 + regsub -all {\n\s+} [string trim $txt] \n txt 90 + regsub -all -command \ 91 + {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt wappInt-enc txt 92 + dict append wapp .reply [subst -novariables -nocommand $txt] 93 + } 94 + proc wappInt-enc {all mode nu1 txt} { 95 + return [uplevel 2 "wappInt-enc-$mode \"$txt\""] 96 + } 97 +} else { 98 + proc wapp-subst {txt} { 99 + global wapp 100 + regsub -all {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt \ 101 + {[wappInt-enc-\1 "\3"]} txt 102 + dict append wapp .reply [uplevel 1 [list subst -novariables $txt]] 103 + } 104 + proc wapp-trim {txt} { 105 + global wapp 106 + regsub -all {\n\s+} [string trim $txt] \n txt 107 + regsub -all {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt \ 108 + {[wappInt-enc-\1 "\3"]} txt 109 + dict append wapp .reply [uplevel 1 [list subst -novariables $txt]] 110 + } 111 +} 112 + 113 +# There must be a wappInt-enc-NAME routine for each possible substitution 114 +# in wapp-subst. Thus there are routines for "html", "url", "qp", and "unsafe". 115 +# 116 +# wappInt-enc-html Escape text so that it is safe to use in the 117 +# body of an HTML document. 118 +# 119 +# wappInt-enc-url Escape text so that it is safe to pass as an 120 +# argument to href= and src= attributes in HTML. 121 +# 122 +# wappInt-enc-qp Escape text so that it is safe to use as the 123 +# value of a query parameter in a URL or in 124 +# post data or in a cookie. 125 +# 126 +# wappInt-enc-string Escape ", ', \, and < for using inside of a 127 +# javascript string literal. The < character 128 +# is escaped to prevent "</script>" from causing 129 +# problems in embedded javascript. 130 +# 131 +# wappInt-enc-unsafe Perform no encoding at all. Unsafe. 132 +# 133 +proc wappInt-enc-html {txt} { 134 + return [string map {& & < < > > \" " \\ \} $txt] 135 +} 136 +proc wappInt-enc-unsafe {txt} { 137 + return $txt 138 +} 139 +proc wappInt-enc-url {s} { 140 + if {[regsub -all {[^-{}@~?=#_.:/a-zA-Z0-9]} $s {[wappInt-%HHchar {&}]} s]} { 141 + set s [subst -novar -noback $s] 142 + } 143 + if {[regsub -all {[{}]} $s {[wappInt-%HHchar \\&]} s]} { 144 + set s [subst -novar -noback $s] 145 + } 146 + return $s 147 +} 148 +proc wappInt-enc-qp {s} { 149 + if {[regsub -all {[^-{}_.a-zA-Z0-9]} $s {[wappInt-%HHchar {&}]} s]} { 150 + set s [subst -novar -noback $s] 151 + } 152 + if {[regsub -all {[{}]} $s {[wappInt-%HHchar \\&]} s]} { 153 + set s [subst -novar -noback $s] 154 + } 155 + return $s 156 +} 157 +proc wappInt-enc-string {s} { 158 + return [string map {\\ \\\\ \" \\\" ' \\' < \\u003c} $s] 159 +} 160 + 161 +# This is a helper routine for wappInt-enc-url and wappInt-enc-qp. It returns 162 +# an appropriate %HH encoding for the single character c. If c is a unicode 163 +# character, then this routine might return multiple bytes: %HH%HH%HH 164 +# 165 +proc wappInt-%HHchar {c} { 166 + if {$c==" "} {return +} 167 + return [regsub -all .. [binary encode hex [encoding convertto utf-8 $c]] {%&}] 168 +} 169 + 170 + 171 +# Undo the www-url-encoded format. 172 +# 173 +# HT: This code stolen from ncgi.tcl 174 +# 175 +proc wappInt-decode-url {str} { 176 + set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str] 177 + regsub -all -- \ 178 + {%([Ee][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \ 179 + $str {[encoding convertfrom utf-8 [binary decode hex \1\2\3]]} str 180 + regsub -all -- \ 181 + {%([CDcd][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \ 182 + $str {[encoding convertfrom utf-8 [binary decode hex \1\2]]} str 183 + regsub -all -- {%([0-7][A-Fa-f0-9])} $str {\\u00\1} str 184 + return [subst -novar $str] 185 +} 186 + 187 +# Reset the document back to an empty string. 188 +# 189 +proc wapp-reset {} { 190 + global wapp 191 + dict set wapp .reply {} 192 +} 193 + 194 +# Change the mime-type of the result document. 195 +# 196 +proc wapp-mimetype {x} { 197 + global wapp 198 + dict set wapp .mimetype $x 199 +} 200 + 201 +# Change the reply code. 202 +# 203 +proc wapp-reply-code {x} { 204 + global wapp 205 + dict set wapp .reply-code $x 206 +} 207 + 208 +# Set a cookie 209 +# 210 +proc wapp-set-cookie {name value} { 211 + global wapp 212 + dict lappend wapp .new-cookies $name $value 213 +} 214 + 215 +# Unset a cookie 216 +# 217 +proc wapp-clear-cookie {name} { 218 + wapp-set-cookie $name {} 219 +} 220 + 221 +# Add extra entries to the reply header 222 +# 223 +proc wapp-reply-extra {name value} { 224 + global wapp 225 + dict lappend wapp .reply-extra $name $value 226 +} 227 + 228 +# Specifies how the web-page under construction should be cached. 229 +# The argument should be one of: 230 +# 231 +# no-cache 232 +# max-age=N (for some integer number of seconds, N) 233 +# private,max-age=N 234 +# 235 +proc wapp-cache-control {x} { 236 + wapp-reply-extra Cache-Control $x 237 +} 238 + 239 +# Redirect to a different web page 240 +# 241 +proc wapp-redirect {uri} { 242 + wapp-reply-code {307 Redirect} 243 + wapp-reply-extra Location $uri 244 +} 245 + 246 +# Return the value of a wapp parameter 247 +# 248 +proc wapp-param {name {dflt {}}} { 249 + global wapp 250 + if {![dict exists $wapp $name]} {return $dflt} 251 + return [dict get $wapp $name] 252 +} 253 + 254 +# Return true if a and only if the wapp parameter $name exists 255 +# 256 +proc wapp-param-exists {name} { 257 + global wapp 258 + return [dict exists $wapp $name] 259 +} 260 + 261 +# Set the value of a wapp parameter 262 +# 263 +proc wapp-set-param {name value} { 264 + global wapp 265 + dict set wapp $name $value 266 +} 267 + 268 +# Return all parameter names that match the GLOB pattern, or all 269 +# names if the GLOB pattern is omitted. 270 +# 271 +proc wapp-param-list {{glob {*}}} { 272 + global wapp 273 + return [dict keys $wapp $glob] 274 +} 275 + 276 +# By default, Wapp does not decode query parameters and POST parameters 277 +# for cross-origin requests. This is a security restriction, designed to 278 +# help prevent cross-site request forgery (CSRF) attacks. 279 +# 280 +# As a consequence of this restriction, URLs for sites generated by Wapp 281 +# that contain query parameters will not work as URLs found in other 282 +# websites. You cannot create a link from a second website into a Wapp 283 +# website if the link contains query planner, by default. 284 +# 285 +# Of course, it is sometimes desirable to allow query parameters on external 286 +# links. For URLs for which this is safe, the application should invoke 287 +# wapp-allow-xorigin-params. This procedure tells Wapp that it is safe to 288 +# go ahead and decode the query parameters even for cross-site requests. 289 +# 290 +# In other words, for Wapp security is the default setting. Individual pages 291 +# need to actively disable the cross-site request security if those pages 292 +# are safe for cross-site access. 293 +# 294 +proc wapp-allow-xorigin-params {} { 295 + global wapp 296 + if {![dict exists $wapp .qp] && ![dict get $wapp SAME_ORIGIN]} { 297 + wappInt-decode-query-params 298 + } 299 +} 300 + 301 +# Set the content-security-policy. 302 +# 303 +# The default content-security-policy is very strict: "default-src 'self'" 304 +# The default policy prohibits the use of in-line javascript or CSS. 305 +# 306 +# Provide an alternative CSP as the argument. Or use "off" to disable 307 +# the CSP completely. 308 +# 309 +proc wapp-content-security-policy {val} { 310 + global wapp 311 + if {$val=="off"} { 312 + dict unset wapp .csp 313 + } else { 314 + dict set wapp .csp $val 315 + } 316 +} 317 + 318 +# Examine the bodys of all procedures in this program looking for 319 +# unsafe calls to various Wapp interfaces. Return a text string 320 +# containing warnings. Return an empty string if all is ok. 321 +# 322 +# This routine is advisory only. It misses some constructs that are 323 +# dangerous and flags others that are safe. 324 +# 325 +proc wapp-safety-check {} { 326 + set res {} 327 + foreach p [info procs] { 328 + set ln 0 329 + foreach x [split [info body $p] \n] { 330 + incr ln 331 + if {[regexp {^[ \t]*wapp[ \t]+([^\n]+)} $x all tail] 332 + && [string index $tail 0]!="\173" 333 + && [regexp {[[$]} $tail] 334 + } { 335 + append res "$p:$ln: unsafe \"wapp\" call: \"[string trim $x]\"\n" 336 + } 337 + if {[regexp {^[ \t]*wapp-(subst|trim)[ \t]+[^\173]} $x all cx]} { 338 + append res "$p:$ln: unsafe \"wapp-$cx\" call: \"[string trim $x]\"\n" 339 + } 340 + } 341 + } 342 + return $res 343 +} 344 + 345 +# Return a string that descripts the current environment. Applications 346 +# might find this useful for debugging. 347 +# 348 +proc wapp-debug-env {} { 349 + global wapp 350 + set out {} 351 + foreach var [lsort [dict keys $wapp]] { 352 + if {[string index $var 0]=="."} continue 353 + append out "$var = [list [dict get $wapp $var]]\n" 354 + } 355 + append out "\[pwd\] = [list [pwd]]\n" 356 + return $out 357 +} 358 + 359 +# Tracing function for each HTTP request. This is overridden by wapp-start 360 +# if tracing is enabled. 361 +# 362 +proc wappInt-trace {} {} 363 + 364 +# Start up a listening socket. Arrange to invoke wappInt-new-connection 365 +# for each inbound HTTP connection. 366 +# 367 +# port Listen on this TCP port. 0 means to select a port 368 +# that is not currently in use 369 +# 370 +# wappmode One of "scgi", "remote-scgi", "server", or "local". 371 +# 372 +# fromip If not {}, then reject all requests from IP addresses 373 +# other than $fromip 374 +# 375 +proc wappInt-start-listener {port wappmode fromip} { 376 + if {[string match *scgi $wappmode]} { 377 + set type SCGI 378 + set server [list wappInt-new-connection \ 379 + wappInt-scgi-readable $wappmode $fromip] 380 + } else { 381 + set type HTTP 382 + set server [list wappInt-new-connection \ 383 + wappInt-http-readable $wappmode $fromip] 384 + } 385 + if {$wappmode=="local" || $wappmode=="scgi"} { 386 + set x [socket -server $server -myaddr 127.0.0.1 $port] 387 + } else { 388 + set x [socket -server $server $port] 389 + } 390 + set coninfo [chan configure $x -sockname] 391 + set port [lindex $coninfo 2] 392 + if {$wappmode=="local"} { 393 + wappInt-start-browser http://127.0.0.1:$port/ 394 + } elseif {$fromip!=""} { 395 + puts "Listening for $type requests on TCP port $port from IP $fromip" 396 + } else { 397 + puts "Listening for $type requests on TCP port $port" 398 + } 399 +} 400 + 401 +# Start a web-browser and point it at $URL 402 +# 403 +proc wappInt-start-browser {url} { 404 + global tcl_platform 405 + if {$tcl_platform(platform)=="windows"} { 406 + exec cmd /c start $url & 407 + } elseif {$tcl_platform(os)=="Darwin"} { 408 + exec open $url & 409 + } elseif {[catch {exec xdg-open $url}]} { 410 + exec firefox $url & 411 + } 412 +} 413 + 414 +# This routine is a "socket -server" callback. The $chan, $ip, and $port 415 +# arguments are added by the socket command. 416 +# 417 +# Arrange to invoke $callback when content is available on the new socket. 418 +# The $callback will process inbound HTTP or SCGI content. Reject the 419 +# request if $fromip is not an empty string and does not match $ip. 420 +# 421 +proc wappInt-new-connection {callback wappmode fromip chan ip port} { 422 + upvar #0 wappInt-$chan W 423 + if {$fromip!="" && ![string match $fromip $ip]} { 424 + close $chan 425 + return 426 + } 427 + set W [dict create REMOTE_ADDR $ip REMOTE_PORT $port WAPP_MODE $wappmode \ 428 + .header {}] 429 + fconfigure $chan -blocking 0 -translation binary 430 + fileevent $chan readable [list $callback $chan] 431 +} 432 + 433 +# Close an input channel 434 +# 435 +proc wappInt-close-channel {chan} { 436 + if {$chan=="stdout"} { 437 + # This happens after completing a CGI request 438 + exit 0 439 + } else { 440 + unset ::wappInt-$chan 441 + close $chan 442 + } 443 +} 444 + 445 +# Process new text received on an inbound HTTP request 446 +# 447 +proc wappInt-http-readable {chan} { 448 + if {[catch [list wappInt-http-readable-unsafe $chan] msg]} { 449 + puts stderr "$msg\n$::errorInfo" 450 + wappInt-close-channel $chan 451 + } 452 +} 453 +proc wappInt-http-readable-unsafe {chan} { 454 + upvar #0 wappInt-$chan W wapp wapp 455 + if {![dict exists $W .toread]} { 456 + # If the .toread key is not set, that means we are still reading 457 + # the header 458 + set line [string trimright [gets $chan]] 459 + set n [string length $line] 460 + if {$n>0} { 461 + if {[dict get $W .header]=="" || [regexp {^\s+} $line]} { 462 + dict append W .header $line 463 + } else { 464 + dict append W .header \n$line 465 + } 466 + if {[string length [dict get $W .header]]>100000} { 467 + error "HTTP request header too big - possible DOS attack" 468 + } 469 + } elseif {$n==0} { 470 + # We have reached the blank line that terminates the header. 471 + global argv0 472 + set a0 [file normalize $argv0] 473 + dict set W SCRIPT_FILENAME $a0 474 + dict set W DOCUMENT_ROOT [file dir $a0] 475 + if {[wappInt-parse-header $chan]} { 476 + catch {close $chan} 477 + return 478 + } 479 + set len 0 480 + if {[dict exists $W CONTENT_LENGTH]} { 481 + set len [dict get $W CONTENT_LENGTH] 482 + } 483 + if {$len>0} { 484 + # Still need to read the query content 485 + dict set W .toread $len 486 + } else { 487 + # There is no query content, so handle the request immediately 488 + set wapp $W 489 + wappInt-handle-request $chan 0 490 + } 491 + } 492 + } else { 493 + # If .toread is set, that means we are reading the query content. 494 + # Continue reading until .toread reaches zero. 495 + set got [read $chan [dict get $W .toread]] 496 + dict append W CONTENT $got 497 + dict set W .toread [expr {[dict get $W .toread]-[string length $got]}] 498 + if {[dict get $W .toread]<=0} { 499 + # Handle the request as soon as all the query content is received 500 + set wapp $W 501 + wappInt-handle-request $chan 0 502 + } 503 + } 504 +} 505 + 506 +# Decode the HTTP request header. 507 +# 508 +# This routine is always running inside of a [catch], so if 509 +# any problems arise, simply raise an error. 510 +# 511 +proc wappInt-parse-header {chan} { 512 + upvar #0 wappInt-$chan W 513 + set hdr [split [dict get $W .header] \n] 514 + if {$hdr==""} {return 1} 515 + set req [lindex $hdr 0] 516 + dict set W REQUEST_METHOD [set method [lindex $req 0]] 517 + if {[lsearch {GET HEAD POST} $method]<0} { 518 + error "unsupported request method: \"[dict get $W REQUEST_METHOD]\"" 519 + } 520 + set uri [lindex $req 1] 521 + set split_uri [split $uri ?] 522 + set uri0 [lindex $split_uri 0] 523 + if {![regexp {^/[-.a-z0-9_/]*$} $uri0]} { 524 + error "invalid request uri: \"$uri0\"" 525 + } 526 + dict set W REQUEST_URI $uri0 527 + dict set W PATH_INFO $uri0 528 + set uri1 [lindex $split_uri 1] 529 + dict set W QUERY_STRING $uri1 530 + set n [llength $hdr] 531 + for {set i 1} {$i<$n} {incr i} { 532 + set x [lindex $hdr $i] 533 + if {![regexp {^(.+): +(.*)$} $x all name value]} { 534 + error "invalid header line: \"$x\"" 535 + } 536 + set name [string toupper $name] 537 + switch -- $name { 538 + REFERER {set name HTTP_REFERER} 539 + USER-AGENT {set name HTTP_USER_AGENT} 540 + CONTENT-LENGTH {set name CONTENT_LENGTH} 541 + CONTENT-TYPE {set name CONTENT_TYPE} 542 + HOST {set name HTTP_HOST} 543 + COOKIE {set name HTTP_COOKIE} 544 + ACCEPT-ENCODING {set name HTTP_ACCEPT_ENCODING} 545 + default {set name .hdr:$name} 546 + } 547 + dict set W $name $value 548 + } 549 + return 0 550 +} 551 + 552 +# Decode the QUERY_STRING parameters from a GET request or the 553 +# application/x-www-form-urlencoded CONTENT from a POST request. 554 +# 555 +# This routine sets the ".qp" element of the ::wapp dict as a signal 556 +# that query parameters have already been decoded. 557 +# 558 +proc wappInt-decode-query-params {} { 559 + global wapp 560 + dict set wapp .qp 1 561 + if {[dict exists $wapp QUERY_STRING]} { 562 + foreach qterm [split [dict get $wapp QUERY_STRING] &] { 563 + set qsplit [split $qterm =] 564 + set nm [lindex $qsplit 0] 565 + if {[regexp {^[a-z][a-z0-9]*$} $nm]} { 566 + dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]] 567 + } 568 + } 569 + } 570 + if {[dict exists $wapp CONTENT_TYPE] && [dict exists $wapp CONTENT]} { 571 + set ctype [dict get $wapp CONTENT_TYPE] 572 + if {$ctype=="application/x-www-form-urlencoded"} { 573 + foreach qterm [split [string trim [dict get $wapp CONTENT]] &] { 574 + set qsplit [split $qterm =] 575 + set nm [lindex $qsplit 0] 576 + if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} { 577 + dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]] 578 + } 579 + } 580 + } elseif {[string match multipart/form-data* $ctype]} { 581 + regexp {^(.*?)\r\n(.*)$} [dict get $wapp CONTENT] all divider body 582 + set ndiv [string length $divider] 583 + while {[string length $body]} { 584 + set idx [string first $divider $body] 585 + set unit [string range $body 0 [expr {$idx-3}]] 586 + set body [string range $body [expr {$idx+$ndiv+2}] end] 587 + if {[regexp {^Content-Disposition: form-data; (.*?)\r\n\r\n(.*)$} \ 588 + $unit unit hdr content]} { 589 + if {[regexp {name="(.*)"; filename="(.*)"\r\nContent-Type: (.*?)$}\ 590 + $hdr hr name filename mimetype]} { 591 + dict set wapp $name.filename \ 592 + [string map [list \\\" \" \\\\ \\] $filename] 593 + dict set wapp $name.mimetype $mimetype 594 + dict set wapp $name.content $content 595 + } elseif {[regexp {name="(.*)"} $hdr hr name]} { 596 + dict set wapp $name $content 597 + } 598 + } 599 + } 600 + } 601 + } 602 +} 603 + 604 +# Invoke application-supplied methods to generate a reply to 605 +# a single HTTP request. 606 +# 607 +# This routine always runs within [catch], so handle exceptions by 608 +# invoking [error]. 609 +# 610 +proc wappInt-handle-request {chan useCgi} { 611 + global wapp 612 + dict set wapp .reply {} 613 + dict set wapp .mimetype {text/html; charset=utf-8} 614 + dict set wapp .reply-code {200 Ok} 615 + dict set wapp .csp {default-src 'self'} 616 + 617 + # Set up additional CGI environment values 618 + # 619 + if {![dict exists $wapp HTTP_HOST]} { 620 + dict set wapp BASE_URL {} 621 + } elseif {[dict exists $wapp HTTPS]} { 622 + dict set wapp BASE_URL https://[dict get $wapp HTTP_HOST] 623 + } else { 624 + dict set wapp BASE_URL http://[dict get $wapp HTTP_HOST] 625 + } 626 + if {![dict exists $wapp REQUEST_URI]} { 627 + dict set wapp REQUEST_URI / 628 + } elseif {[regsub {\?.*} [dict get $wapp REQUEST_URI] {} newR]} { 629 + # Some servers (ex: nginx) append the query parameters to REQUEST_URI. 630 + # These need to be stripped off 631 + dict set wapp REQUEST_URI $newR 632 + } 633 + if {[dict exists $wapp SCRIPT_NAME]} { 634 + dict append wapp BASE_URL [dict get $wapp SCRIPT_NAME] 635 + } else { 636 + dict set wapp SCRIPT_NAME {} 637 + } 638 + if {![dict exists $wapp PATH_INFO]} { 639 + # If PATH_INFO is missing (ex: nginx) then construct it 640 + set URI [dict get $wapp REQUEST_URI] 641 + set skip [string length [dict get $wapp SCRIPT_NAME]] 642 + dict set wapp PATH_INFO [string range $URI $skip end] 643 + } 644 + if {[regexp {^/([^/]+)(.*)$} [dict get $wapp PATH_INFO] all head tail]} { 645 + dict set wapp PATH_HEAD $head 646 + dict set wapp PATH_TAIL [string trimleft $tail /] 647 + } else { 648 + dict set wapp PATH_INFO {} 649 + dict set wapp PATH_HEAD {} 650 + dict set wapp PATH_TAIL {} 651 + } 652 + dict set wapp SELF_URL [dict get $wapp BASE_URL]/[dict get $wapp PATH_HEAD] 653 + 654 + # Parse query parameters from the query string, the cookies, and 655 + # POST data 656 + # 657 + if {[dict exists $wapp HTTP_COOKIE]} { 658 + foreach qterm [split [dict get $wapp HTTP_COOKIE] {;}] { 659 + set qsplit [split [string trim $qterm] =] 660 + set nm [lindex $qsplit 0] 661 + if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} { 662 + dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]] 663 + } 664 + } 665 + } 666 + set same_origin 0 667 + if {[dict exists $wapp HTTP_REFERER]} { 668 + set referer [dict get $wapp HTTP_REFERER] 669 + set base [dict get $wapp BASE_URL] 670 + if {$referer==$base || [string match $base/* $referer]} { 671 + set same_origin 1 672 + } 673 + } 674 + dict set wapp SAME_ORIGIN $same_origin 675 + if {$same_origin} { 676 + wappInt-decode-query-params 677 + } 678 + 679 + # Invoke the application-defined handler procedure for this page 680 + # request. If an error occurs while running that procedure, generate 681 + # an HTTP reply that contains the error message. 682 + # 683 + wapp-before-dispatch-hook 684 + wappInt-trace 685 + set mname [dict get $wapp PATH_HEAD] 686 + if {[catch { 687 + if {$mname!="" && [llength [info proc wapp-page-$mname]]>0} { 688 + wapp-page-$mname 689 + } else { 690 + wapp-default 691 + } 692 + } msg]} { 693 + if {[wapp-param WAPP_MODE]=="local" || [wapp-param WAPP_MODE]=="server"} { 694 + puts "ERROR: $::errorInfo" 695 + } 696 + wapp-reset 697 + wapp-reply-code "500 Internal Server Error" 698 + wapp-mimetype text/html 699 + wapp-trim { 700 + <h1>Wapp Application Error</h1> 701 + <pre>%html($::errorInfo)</pre> 702 + } 703 + dict unset wapp .new-cookies 704 + } 705 + 706 + # Transmit the HTTP reply 707 + # 708 + if {$chan=="stdout"} { 709 + puts $chan "Status: [dict get $wapp .reply-code]\r" 710 + } else { 711 + puts $chan "HTTP/1.1 [dict get $wapp .reply-code]\r" 712 + puts $chan "Server: wapp\r" 713 + puts $chan "Connection: close\r" 714 + } 715 + if {[dict exists $wapp .reply-extra]} { 716 + foreach {name value} [dict get $wapp .reply-extra] { 717 + puts $chan "$name: $value\r" 718 + } 719 + } 720 + if {[dict exists $wapp .csp]} { 721 + puts $chan "Content-Security-Policy: [dict get $wapp .csp]\r" 722 + } 723 + set mimetype [dict get $wapp .mimetype] 724 + puts $chan "Content-Type: $mimetype\r" 725 + if {[dict exists $wapp .new-cookies]} { 726 + foreach {nm val} [dict get $wapp .new-cookies] { 727 + if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} { 728 + if {$val==""} { 729 + puts $chan "Set-Cookie: $nm=; HttpOnly; Path=/; Max-Age=1\r" 730 + } else { 731 + set val [wappInt-enc-url $val] 732 + puts $chan "Set-Cookie: $nm=$val; HttpOnly; Path=/\r" 733 + } 734 + } 735 + } 736 + } 737 + if {[string match text/* $mimetype]} { 738 + set reply [encoding convertto utf-8 [dict get $wapp .reply]] 739 + if {[regexp {\ygzip\y} [wapp-param HTTP_ACCEPT_ENCODING]]} { 740 + catch { 741 + set x [zlib gzip $reply] 742 + set reply $x 743 + puts $chan "Content-Encoding: gzip\r" 744 + } 745 + } 746 + } else { 747 + set reply [dict get $wapp .reply] 748 + } 749 + puts $chan "Content-Length: [string length $reply]\r" 750 + puts $chan \r 751 + puts -nonewline $chan $reply 752 + flush $chan 753 + wappInt-close-channel $chan 754 +} 755 + 756 +# This routine runs just prior to request-handler dispatch. The 757 +# default implementation is a no-op, but applications can override 758 +# to do additional transformations or checks. 759 +# 760 +proc wapp-before-dispatch-hook {} {return} 761 + 762 +# Process a single CGI request 763 +# 764 +proc wappInt-handle-cgi-request {} { 765 + global wapp env 766 + foreach key { 767 + CONTENT_LENGTH 768 + CONTENT_TYPE 769 + DOCUMENT_ROOT 770 + HTTP_ACCEPT_ENCODING 771 + HTTP_COOKIE 772 + HTTP_HOST 773 + HTTP_REFERER 774 + HTTP_USER_AGENT 775 + HTTPS 776 + PATH_INFO 777 + QUERY_STRING 778 + REMOTE_ADDR 779 + REQUEST_METHOD 780 + REQUEST_URI 781 + REMOTE_USER 782 + SCRIPT_FILENAME 783 + SCRIPT_NAME 784 + SERVER_NAME 785 + SERVER_PORT 786 + SERVER_PROTOCOL 787 + } { 788 + if {[info exists env($key)]} { 789 + dict set wapp $key $env($key) 790 + } 791 + } 792 + set len 0 793 + if {[dict exists $wapp CONTENT_LENGTH]} { 794 + set len [dict get $wapp CONTENT_LENGTH] 795 + } 796 + if {$len>0} { 797 + fconfigure stdin -translation binary 798 + dict set wapp CONTENT [read stdin $len] 799 + } 800 + dict set wapp WAPP_MODE cgi 801 + fconfigure stdout -translation binary 802 + wappInt-handle-request stdout 1 803 +} 804 + 805 +# Process new text received on an inbound SCGI request 806 +# 807 +proc wappInt-scgi-readable {chan} { 808 + if {[catch [list wappInt-scgi-readable-unsafe $chan] msg]} { 809 + puts stderr "$msg\n$::errorInfo" 810 + wappInt-close-channel $chan 811 + } 812 +} 813 +proc wappInt-scgi-readable-unsafe {chan} { 814 + upvar #0 wappInt-$chan W wapp wapp 815 + if {![dict exists $W .toread]} { 816 + # If the .toread key is not set, that means we are still reading 817 + # the header. 818 + # 819 + # An SGI header is short. This implementation assumes the entire 820 + # header is available all at once. 821 + # 822 + dict set W .remove_addr [dict get $W REMOTE_ADDR] 823 + set req [read $chan 15] 824 + set n [string length $req] 825 + scan $req %d:%s len hdr 826 + incr len [string length "$len:,"] 827 + append hdr [read $chan [expr {$len-15}]] 828 + foreach {nm val} [split $hdr \000] { 829 + if {$nm==","} break 830 + dict set W $nm $val 831 + } 832 + set len 0 833 + if {[dict exists $W CONTENT_LENGTH]} { 834 + set len [dict get $W CONTENT_LENGTH] 835 + } 836 + if {$len>0} { 837 + # Still need to read the query content 838 + dict set W .toread $len 839 + } else { 840 + # There is no query content, so handle the request immediately 841 + dict set W SERVER_ADDR [dict get $W .remove_addr] 842 + set wapp $W 843 + wappInt-handle-request $chan 0 844 + } 845 + } else { 846 + # If .toread is set, that means we are reading the query content. 847 + # Continue reading until .toread reaches zero. 848 + set got [read $chan [dict get $W .toread]] 849 + dict append W CONTENT $got 850 + dict set W .toread [expr {[dict get $W .toread]-[string length $got]}] 851 + if {[dict get $W .toread]<=0} { 852 + # Handle the request as soon as all the query content is received 853 + dict set W SERVER_ADDR [dict get $W .remove_addr] 854 + set wapp $W 855 + wappInt-handle-request $chan 0 856 + } 857 + } 858 +} 859 + 860 +# Start up the wapp framework. Parameters are a list passed as the 861 +# single argument. 862 +# 863 +# -server $PORT Listen for HTTP requests on this TCP port $PORT 864 +# 865 +# -local $PORT Listen for HTTP requests on 127.0.0.1:$PORT 866 +# 867 +# -scgi $PORT Listen for SCGI requests on 127.0.0.1:$PORT 868 +# 869 +# -remote-scgi $PORT Listen for SCGI requests on TCP port $PORT 870 +# 871 +# -cgi Handle a single CGI request 872 +# 873 +# With no arguments, the behavior is called "auto". In "auto" mode, 874 +# if the GATEWAY_INTERFACE environment variable indicates CGI, then run 875 +# as CGI. Otherwise, start an HTTP server bound to the loopback address 876 +# only, on an arbitrary TCP port, and automatically launch a web browser 877 +# on that TCP port. 878 +# 879 +# Additional options: 880 +# 881 +# -fromip GLOB Reject any incoming request where the remote 882 +# IP address does not match the GLOB pattern. This 883 +# value defaults to '127.0.0.1' for -local and -scgi. 884 +# 885 +# -nowait Do not wait in the event loop. Return immediately 886 +# after all event handlers are established. 887 +# 888 +# -trace "puts" each request URL as it is handled, for 889 +# debugging 890 +# 891 +# -lint Run wapp-safety-check on the application instead 892 +# of running the application itself 893 +# 894 +# -Dvar=value Set TCL global variable "var" to "value" 895 +# 896 +# 897 +proc wapp-start {arglist} { 898 + global env 899 + set mode auto 900 + set port 0 901 + set nowait 0 902 + set fromip {} 903 + set n [llength $arglist] 904 + for {set i 0} {$i<$n} {incr i} { 905 + set term [lindex $arglist $i] 906 + if {[string match --* $term]} {set term [string range $term 1 end]} 907 + switch -glob -- $term { 908 + -server { 909 + incr i; 910 + set mode "server" 911 + set port [lindex $arglist $i] 912 + } 913 + -local { 914 + incr i; 915 + set mode "local" 916 + set fromip 127.0.0.1 917 + set port [lindex $arglist $i] 918 + } 919 + -scgi { 920 + incr i; 921 + set mode "scgi" 922 + set fromip 127.0.0.1 923 + set port [lindex $arglist $i] 924 + } 925 + -remote-scgi { 926 + incr i; 927 + set mode "remote-scgi" 928 + set port [lindex $arglist $i] 929 + } 930 + -cgi { 931 + set mode "cgi" 932 + } 933 + -fromip { 934 + incr i 935 + set fromip [lindex $arglist $i] 936 + } 937 + -nowait { 938 + set nowait 1 939 + } 940 + -trace { 941 + proc wappInt-trace {} { 942 + set q [wapp-param QUERY_STRING] 943 + set uri [wapp-param BASE_URL][wapp-param PATH_INFO] 944 + if {$q!=""} {append uri ?$q} 945 + puts $uri 946 + } 947 + } 948 + -lint { 949 + set res [wapp-safety-check] 950 + if {$res!=""} { 951 + puts "Potential problems in this code:" 952 + puts $res 953 + exit 1 954 + } else { 955 + exit 956 + } 957 + } 958 + -D*=* { 959 + if {[regexp {^.D([^=]+)=(.*)$} $term all var val]} { 960 + set ::$var $val 961 + } 962 + } 963 + default { 964 + error "unknown option: $term" 965 + } 966 + } 967 + } 968 + if {$mode=="auto"} { 969 + if {[info exists env(GATEWAY_INTERFACE)] 970 + && [string match CGI/1.* $env(GATEWAY_INTERFACE)]} { 971 + set mode cgi 972 + } else { 973 + set mode local 974 + } 975 + } 976 + if {$mode=="cgi"} { 977 + wappInt-handle-cgi-request 978 + } else { 979 + wappInt-start-listener $port $mode $fromip 980 + if {!$nowait} { 981 + vwait ::forever 982 + } 983 + } 984 +} 985 + 986 +# Call this version 1.0 987 +package provide wapp 1.0
Added test/wapptest.tcl.
1 +#!/bin/sh 2 +# \ 3 +exec wapptclsh "$0" ${1+"$@"} 4 + 5 +# package required wapp 6 +source [file join [file dirname [info script]] wapp.tcl] 7 + 8 +# Read the data from the releasetest_data.tcl script. 9 +# 10 +source [file join [file dirname [info script]] releasetest_data.tcl] 11 + 12 +# Variables set by the "control" form: 13 +# 14 +# G(platform) - User selected platform. 15 +# G(test) - Set to "Normal", "Veryquick", "Smoketest" or "Build-Only". 16 +# G(keep) - Boolean. True to delete no files after each test. 17 +# G(msvc) - Boolean. True to use MSVC as the compiler. 18 +# G(tcl) - Use Tcl from this directory for builds. 19 +# G(jobs) - How many sub-processes to run simultaneously. 20 +# 21 +set G(platform) $::tcl_platform(os)-$::tcl_platform(machine) 22 +set G(test) Normal 23 +set G(keep) 0 24 +set G(msvc) 0 25 +set G(tcl) [::tcl::pkgconfig get libdir,install] 26 +set G(jobs) 3 27 +set G(debug) 0 28 + 29 +proc wapptest_init {} { 30 + global G 31 + 32 + set lSave [list platform test keep msvc tcl jobs debug] 33 + foreach k $lSave { set A($k) $G($k) } 34 + array unset G 35 + foreach k $lSave { set G($k) $A($k) } 36 + 37 + # The root of the SQLite source tree. 38 + set G(srcdir) [file dirname [file dirname [info script]]] 39 + 40 + # releasetest.tcl script 41 + set G(releaseTest) [file join [file dirname [info script]] releasetest.tcl] 42 + 43 + set G(sqlite_version) "unknown" 44 + 45 + # Either "config", "running" or "stopped": 46 + set G(state) "config" 47 + 48 + set G(hostname) "(unknown host)" 49 + catch { set G(hostname) [exec hostname] } 50 + set G(host) $G(hostname) 51 + append G(host) " $::tcl_platform(os) $::tcl_platform(osVersion)" 52 + append G(host) " $::tcl_platform(machine) $::tcl_platform(byteOrder)" 53 +} 54 + 55 +# Check to see if there are uncommitted changes in the SQLite source 56 +# directory. Return true if there are, or false otherwise. 57 +# 58 +proc check_uncommitted {} { 59 + global G 60 + set ret 0 61 + set pwd [pwd] 62 + cd $G(srcdir) 63 + if {[catch {exec fossil changes} res]==0 && [string trim $res]!=""} { 64 + set ret 1 65 + } 66 + cd $pwd 67 + return $ret 68 +} 69 + 70 +proc generate_fossil_info {} { 71 + global G 72 + set pwd [pwd] 73 + cd $G(srcdir) 74 + if {[catch {exec fossil info} r1]} return 75 + if {[catch {exec fossil changes} r2]} return 76 + cd $pwd 77 + 78 + foreach line [split $r1 "\n"] { 79 + if {[regexp {^checkout: *(.*)$} $line -> co]} { 80 + wapp-trim { <br> %html($co) } 81 + } 82 + } 83 + 84 + if {[string trim $r2]!=""} { 85 + wapp-trim { 86 + <br><span class=warning> 87 + WARNING: Uncommitted changes in checkout 88 + </span> 89 + } 90 + } 91 +} 92 + 93 +# If the application is in "config" state, set the contents of the 94 +# ::G(test_array) global to reflect the tests that will be run. If the 95 +# app is in some other state ("running" or "stopped"), this command 96 +# is a no-op. 97 +# 98 +proc set_test_array {} { 99 + global G 100 + if { $G(state)=="config" } { 101 + set G(test_array) [list] 102 + foreach {config target} $::Platforms($G(platform)) { 103 + 104 + # If using MSVC, do not run sanitize or valgrind tests. Or the 105 + # checksymbols test. 106 + if {$G(msvc) && ( 107 + "Sanitize" == $config 108 + || "checksymbols" in $target 109 + || "valgrindtest" in $target 110 + )} { 111 + continue 112 + } 113 + 114 + # If the test mode is not "Normal", override the target. 115 + # 116 + if {$target!="checksymbols" && $G(platform)!="Failure-Detection"} { 117 + switch -- $G(test) { 118 + Veryquick { set target quicktest } 119 + Smoketest { set target smoketest } 120 + Build-Only { 121 + set target testfixture 122 + if {$::tcl_platform(platform)=="windows"} { 123 + set target testfixture.exe 124 + } 125 + } 126 + } 127 + } 128 + 129 + lappend G(test_array) [dict create config $config target $target] 130 + 131 + set exclude [list checksymbols valgrindtest fuzzoomtest] 132 + if {$G(debug) && !($target in $exclude)} { 133 + set debug_idx [lsearch -glob $::Configs($config) -DSQLITE_DEBUG*] 134 + set xtarget $target 135 + regsub -all {fulltest[a-z]*} $xtarget test xtarget 136 + if {$debug_idx<0} { 137 + lappend G(test_array) [ 138 + dict create config $config-(Debug) target $target 139 + ] 140 + } else { 141 + lappend G(test_array) [ 142 + dict create config $config-(NDebug) target $xtarget 143 + ] 144 + } 145 + } 146 + } 147 + } 148 +} 149 + 150 +proc count_tests_and_errors {name logfile} { 151 + global G 152 + 153 + set fd [open $logfile rb] 154 + set seen 0 155 + while {![eof $fd]} { 156 + set line [gets $fd] 157 + if {[regexp {(\d+) errors out of (\d+) tests} $line all nerr ntest]} { 158 + incr G(test.$name.nError) $nerr 159 + incr G(test.$name.nTest) $ntest 160 + set seen 1 161 + if {$nerr>0} { 162 + set G(test.$name.errmsg) $line 163 + } 164 + } 165 + if {[regexp {runtime error: +(.*)} $line all msg]} { 166 + # skip over "value is outside range" errors 167 + if {[regexp {value .* is outside the range of representable} $line]} { 168 + # noop 169 + } else { 170 + incr G(test.$name.nError) 171 + if {$G(test.$name.errmsg)==""} { 172 + set G(test.$name.errmsg) $msg 173 + } 174 + } 175 + } 176 + if {[regexp {fatal error +(.*)} $line all msg]} { 177 + incr G(test.$name.nError) 178 + if {$G(test.$name.errmsg)==""} { 179 + set G(test.$name.errmsg) $msg 180 + } 181 + } 182 + if {[regexp {ERROR SUMMARY: (\d+) errors.*} $line all cnt] && $cnt>0} { 183 + incr G(test.$name.nError) 184 + if {$G(test.$name.errmsg)==""} { 185 + set G(test.$name.errmsg) $all 186 + } 187 + } 188 + if {[regexp {^VERSION: 3\.\d+.\d+} $line]} { 189 + set v [string range $line 9 end] 190 + if {$G(sqlite_version) eq "unknown"} { 191 + set G(sqlite_version) $v 192 + } elseif {$G(sqlite_version) ne $v} { 193 + set G(test.$name.errmsg) "version conflict: {$G(sqlite_version)} vs. {$v}" 194 + } 195 + } 196 + } 197 + close $fd 198 + if {$G(test) == "Build-Only"} { 199 + incr G(test.$name.nTest) 200 + if {$G(test.$name.nError)>0} { 201 + set errmsg "Build failed" 202 + } 203 + } elseif {!$seen} { 204 + set G(test.$name.errmsg) "Test did not complete" 205 + if {[file readable core]} { 206 + append G(test.$name.errmsg) " - core file exists" 207 + } 208 + } 209 +} 210 + 211 +proc slave_test_done {name rc} { 212 + global G 213 + set G(test.$name.done) [clock seconds] 214 + set G(test.$name.nError) 0 215 + set G(test.$name.nTest) 0 216 + set G(test.$name.errmsg) "" 217 + if {$rc} { 218 + incr G(test.$name.nError) 219 + } 220 + if {[file exists $G(test.$name.log)]} { 221 + count_tests_and_errors $name $G(test.$name.log) 222 + } 223 +} 224 + 225 +proc slave_fileevent {name} { 226 + global G 227 + set fd $G(test.$name.channel) 228 + 229 + if {[eof $fd]} { 230 + fconfigure $fd -blocking 1 231 + set rc [catch { close $fd }] 232 + unset G(test.$name.channel) 233 + slave_test_done $name $rc 234 + } else { 235 + set line [gets $fd] 236 + if {[string trim $line] != ""} { puts "Trace : $name - \"$line\"" } 237 + } 238 + 239 + do_some_stuff 240 +} 241 + 242 +proc do_some_stuff {} { 243 + global G 244 + 245 + # Count the number of running jobs. A running job has an entry named 246 + # "channel" in its dictionary. 247 + set nRunning 0 248 + set bFinished 1 249 + foreach j $G(test_array) { 250 + set name [dict get $j config] 251 + if { [info exists G(test.$name.channel)]} { incr nRunning } 252 + if {![info exists G(test.$name.done)]} { set bFinished 0 } 253 + } 254 + 255 + if {$bFinished} { 256 + set nError 0 257 + set nTest 0 258 + set nConfig 0 259 + foreach j $G(test_array) { 260 + set name [dict get $j config] 261 + incr nError $G(test.$name.nError) 262 + incr nTest $G(test.$name.nTest) 263 + incr nConfig 264 + } 265 + set G(result) "$nError errors from $nTest tests in $nConfig configurations." 266 + catch { 267 + append G(result) " SQLite version $G(sqlite_version)" 268 + } 269 + set G(state) "stopped" 270 + } else { 271 + set nLaunch [expr $G(jobs) - $nRunning] 272 + foreach j $G(test_array) { 273 + if {$nLaunch<=0} break 274 + set name [dict get $j config] 275 + if { ![info exists G(test.$name.channel)] 276 + && ![info exists G(test.$name.done)] 277 + } { 278 + set target [dict get $j target] 279 + set G(test.$name.start) [clock seconds] 280 + set fd [open "|[info nameofexecutable] $G(releaseTest) --slave" r+] 281 + set G(test.$name.channel) $fd 282 + fconfigure $fd -blocking 0 283 + fileevent $fd readable [list slave_fileevent $name] 284 + 285 + puts $fd [list 0 $G(msvc) 0 $G(keep)] 286 + 287 + set wtcl "" 288 + if {$G(tcl)!=""} { set wtcl "--with-tcl=$G(tcl)" } 289 + 290 + # If this configuration is named <name>-(Debug) or <name>-(NDebug), 291 + # then add or remove the SQLITE_DEBUG option from the base 292 + # configuration before running the test. 293 + if {[regexp -- {(.*)-(\(.*\))} $name -> head tail]} { 294 + set opts $::Configs($head) 295 + if {$tail=="(Debug)"} { 296 + append opts " -DSQLITE_DEBUG=1 -DSQLITE_EXTRA_IFNULLROW=1" 297 + } else { 298 + regsub { *-DSQLITE_MEMDEBUG[^ ]* *} $opts { } opts 299 + regsub { *-DSQLITE_DEBUG[^ ]* *} $opts { } opts 300 + } 301 + } else { 302 + set opts $::Configs($name) 303 + } 304 + 305 + set L [make_test_suite $G(msvc) $wtcl $name $target $opts] 306 + puts $fd $L 307 + flush $fd 308 + set G(test.$name.log) [file join [lindex $L 1] test.log] 309 + incr nLaunch -1 310 + } 311 + } 312 + } 313 +} 314 + 315 +proc generate_select_widget {label id lOpt opt} { 316 + wapp-trim { 317 + <label> %string($label) </label> 318 + <select id=%string($id) name=%string($id)> 319 + } 320 + foreach o $lOpt { 321 + set selected "" 322 + if {$o==$opt} { set selected " selected=1" } 323 + wapp-subst "<option $selected>$o</option>" 324 + } 325 + wapp-trim { </select> } 326 +} 327 + 328 +proc generate_main_page {{extra {}}} { 329 + global G 330 + set_test_array 331 + 332 + set hostname $G(hostname) 333 + wapp-trim { 334 + <html> 335 + <head> 336 + <title> %html($hostname): wapptest.tcl </title> 337 + <link rel="stylesheet" type="text/css" href="style.css"/> 338 + </head> 339 + <body> 340 + } 341 + 342 + set host $G(host) 343 + wapp-trim { 344 + <div class="border">%string($host) 345 + } 346 + generate_fossil_info 347 + wapp-trim { 348 + </div> 349 + <div class="border" id=controls> 350 + <form action="control" method="post" name="control"> 351 + } 352 + 353 + # Build the "platform" select widget. 354 + set lOpt [array names ::Platforms] 355 + generate_select_widget Platform control_platform $lOpt $G(platform) 356 + 357 + # Build the "test" select widget. 358 + set lOpt [list Normal Veryquick Smoketest Build-Only] 359 + generate_select_widget Test control_test $lOpt $G(test) 360 + 361 + # Build the "jobs" select widget. Options are 1 to 8. 362 + generate_select_widget Jobs control_jobs {1 2 3 4 5 6 7 8} $G(jobs) 363 + 364 + switch $G(state) { 365 + config { 366 + set txt "Run Tests!" 367 + set id control_run 368 + } 369 + running { 370 + set txt "STOP Tests!" 371 + set id control_stop 372 + } 373 + stopped { 374 + set txt "Reset!" 375 + set id control_reset 376 + } 377 + } 378 + wapp-trim { 379 + <div class=right> 380 + <input id=%string($id) name=%string($id) type=submit value="%string($txt)"> 381 + </input> 382 + </div> 383 + } 384 + 385 + wapp-trim { 386 + <br><br> 387 + <label> Tcl: </label> 388 + <input id="control_tcl" name="control_tcl"></input> 389 + <label> Keep files: </label> 390 + <input id="control_keep" name="control_keep" type=checkbox value=1> 391 + </input> 392 + <label> Use MSVC: </label> 393 + <input id="control_msvc" name="control_msvc" type=checkbox value=1> 394 + <label> Debug tests: </label> 395 + <input id="control_debug" name="control_debug" type=checkbox value=1> 396 + </input> 397 + } 398 + wapp-trim { 399 + </form> 400 + } 401 + wapp-trim { 402 + </div> 403 + <div id=tests> 404 + } 405 + wapp-page-tests 406 + 407 + set script "script/$G(state).js" 408 + wapp-trim { 409 + </div> 410 + <script src=%string($script)></script> 411 + </body> 412 + </html> 413 + } 414 +} 415 + 416 +proc wapp-default {} { 417 + generate_main_page 418 +} 419 + 420 +proc wapp-page-tests {} { 421 + global G 422 + wapp-trim { <table class="border" width=100%> } 423 + foreach t $G(test_array) { 424 + set config [dict get $t config] 425 + set target [dict get $t target] 426 + 427 + set class "testwait" 428 + set seconds "" 429 + 430 + if {[info exists G(test.$config.log)]} { 431 + if {[info exists G(test.$config.channel)]} { 432 + set class "testrunning" 433 + set seconds [expr [clock seconds] - $G(test.$config.start)] 434 + } elseif {[info exists G(test.$config.done)]} { 435 + if {$G(test.$config.nError)>0} { 436 + set class "testfail" 437 + } else { 438 + set class "testdone" 439 + } 440 + set seconds [expr $G(test.$config.done) - $G(test.$config.start)] 441 + } 442 + 443 + set min [format %.2d [expr ($seconds / 60) % 60]] 444 + set hr [format %.2d [expr $seconds / 3600]] 445 + set sec [format %.2d [expr $seconds % 60]] 446 + set seconds "$hr:$min:$sec" 447 + } 448 + 449 + wapp-trim { 450 + <tr class=%string($class)> 451 + <td class="nowrap"> %html($config) 452 + <td class="padleft nowrap"> %html($target) 453 + <td class="padleft nowrap"> %html($seconds) 454 + <td class="padleft nowrap"> 455 + } 456 + if {[info exists G(test.$config.log)]} { 457 + set log $G(test.$config.log) 458 + set uri "log/$log" 459 + wapp-trim { 460 + <a href=%url($uri)> %html($log) </a> 461 + } 462 + } 463 + if {[info exists G(test.$config.errmsg)] && $G(test.$config.errmsg)!=""} { 464 + set errmsg $G(test.$config.errmsg) 465 + wapp-trim { 466 + <tr class=testfail> 467 + <td> <td class="padleft" colspan=3> %html($errmsg) 468 + } 469 + } 470 + } 471 + 472 + wapp-trim { </table> } 473 + 474 + if {[info exists G(result)]} { 475 + set res $G(result) 476 + wapp-trim { 477 + <div class=border id=result> %string($res) </div> 478 + } 479 + } 480 +} 481 + 482 +# URI: /control 483 +# 484 +# Whenever the form at the top of the application page is submitted, it 485 +# is submitted here. 486 +# 487 +proc wapp-page-control {} { 488 + global G 489 + if {$::G(state)=="config"} { 490 + set lControls [list platform test tcl jobs keep msvc debug] 491 + set G(msvc) 0 492 + set G(keep) 0 493 + set G(debug) 0 494 + } else { 495 + set lControls [list jobs] 496 + } 497 + foreach v $lControls { 498 + if {[wapp-param-exists control_$v]} { 499 + set G($v) [wapp-param control_$v] 500 + } 501 + } 502 + 503 + if {[wapp-param-exists control_run]} { 504 + # This is a "run test" command. 505 + set_test_array 506 + set ::G(state) "running" 507 + } 508 + 509 + if {[wapp-param-exists control_stop]} { 510 + # A "STOP tests" command. 511 + set G(state) "stopped" 512 + set G(result) "Test halted by user" 513 + foreach j $G(test_array) { 514 + set name [dict get $j config] 515 + if { [info exists G(test.$name.channel)] } { 516 + close $G(test.$name.channel) 517 + unset G(test.$name.channel) 518 + slave_test_done $name 1 519 + } 520 + } 521 + } 522 + 523 + if {[wapp-param-exists control_reset]} { 524 + # A "reset app" command. 525 + set G(state) "config" 526 + wapptest_init 527 + } 528 + 529 + if {$::G(state) == "running"} { 530 + do_some_stuff 531 + } 532 + wapp-redirect / 533 +} 534 + 535 +# URI: /style.css 536 +# 537 +# Return the stylesheet for the application main page. 538 +# 539 +proc wapp-page-style.css {} { 540 + wapp-subst { 541 + 542 + /* The boxes with black borders use this class */ 543 + .border { 544 + border: 3px groove #444444; 545 + padding: 1em; 546 + margin-top: 1em; 547 + margin-bottom: 1em; 548 + } 549 + 550 + /* Float to the right (used for the Run/Stop/Reset button) */ 551 + .right { float: right; } 552 + 553 + /* Style for the large red warning at the top of the page */ 554 + .warning { 555 + color: red; 556 + font-weight: bold; 557 + } 558 + 559 + /* Styles used by cells in the test table */ 560 + .padleft { padding-left: 5ex; } 561 + .nowrap { white-space: nowrap; } 562 + 563 + /* Styles for individual tests, depending on the outcome */ 564 + .testwait { } 565 + .testrunning { color: blue } 566 + .testdone { color: green } 567 + .testfail { color: red } 568 + } 569 +} 570 + 571 +# URI: /script/${state}.js 572 +# 573 +# The last part of this URI is always "config.js", "running.js" or 574 +# "stopped.js", depending on the state of the application. It returns 575 +# the javascript part of the front-end for the requested state to the 576 +# browser. 577 +# 578 +proc wapp-page-script {} { 579 + regexp {[^/]*$} [wapp-param REQUEST_URI] script 580 + 581 + set tcl $::G(tcl) 582 + set keep $::G(keep) 583 + set msvc $::G(msvc) 584 + set debug $::G(debug) 585 + 586 + wapp-subst { 587 + var lElem = \["control_platform", "control_test", "control_msvc", 588 + "control_jobs", "control_debug" 589 + \]; 590 + lElem.forEach(function(e) { 591 + var elem = document.getElementById(e); 592 + elem.addEventListener("change", function() { control.submit() } ); 593 + }) 594 + 595 + elem = document.getElementById("control_tcl"); 596 + elem.value = "%string($tcl)" 597 + 598 + elem = document.getElementById("control_keep"); 599 + elem.checked = %string($keep); 600 + 601 + elem = document.getElementById("control_msvc"); 602 + elem.checked = %string($msvc); 603 + 604 + elem = document.getElementById("control_debug"); 605 + elem.checked = %string($debug); 606 + } 607 + 608 + if {$script != "config.js"} { 609 + wapp-subst { 610 + var lElem = \["control_platform", "control_test", 611 + "control_tcl", "control_keep", "control_msvc" 612 + \]; 613 + lElem.forEach(function(e) { 614 + var elem = document.getElementById(e); 615 + elem.disabled = true; 616 + }) 617 + } 618 + } 619 + 620 + if {$script == "running.js"} { 621 + wapp-subst { 622 + function reload_tests() { 623 + fetch('tests') 624 + .then( data => data.text() ) 625 + .then( data => { 626 + document.getElementById("tests").innerHTML = data; 627 + }) 628 + .then( data => { 629 + if( document.getElementById("result") ){ 630 + document.location = document.location; 631 + } else { 632 + setTimeout(reload_tests, 1000) 633 + } 634 + }); 635 + } 636 + 637 + setTimeout(reload_tests, 1000) 638 + } 639 + } 640 +} 641 + 642 +# URI: /env 643 +# 644 +# This is for debugging only. Serves no other purpose. 645 +# 646 +proc wapp-page-env {} { 647 + wapp-allow-xorigin-params 648 + wapp-trim { 649 + <h1>Wapp Environment</h1>\n<pre> 650 + <pre>%html([wapp-debug-env])</pre> 651 + } 652 +} 653 + 654 +# URI: /log/dirname/test.log 655 +# 656 +# This URI reads file "dirname/test.log" from disk, wraps it in a <pre> 657 +# block, and returns it to the browser. Use for viewing log files. 658 +# 659 +proc wapp-page-log {} { 660 + set log [string range [wapp-param REQUEST_URI] 5 end] 661 + set fd [open $log] 662 + set data [read $fd] 663 + close $fd 664 + wapp-trim { 665 + <pre> 666 + %html($data) 667 + </pre> 668 + } 669 +} 670 + 671 +wapptest_init 672 +wapp-start $argv 673 +