Add test/wapptest.tcl, a wapp alternative to releasetest.tcl.
FossilOrigin-Name: a4af0c2fee05aaa2e95ae6a5c847ff2d363e24f325f4ffdcf51bc264b9bf5e2d
This commit is contained in:
dan
parent
427db2d245
commit
a3020dcb21
18
manifest
18
manifest
@ -1,5 +1,5 @@
|
||||
C Make\sthe\stestcase()\smacro\sadded\sin\sthe\sprevious\scheck-in\sreachable\sfor\ntesting.
|
||||
D 2019-04-07T18:21:12.384
|
||||
C Add\stest/wapptest.tcl,\sa\swapp\salternative\sto\sreleasetest.tcl.
|
||||
D 2019-04-09T19:53:32.352
|
||||
F .fossil-settings/empty-dirs dbb81e8fc0401ac46a1491ab34a7f2c7c0452f2f06b54ebb845d024ca8283ef1
|
||||
F .fossil-settings/ignore-glob 35175cdfcf539b2318cb04a9901442804be81cd677d8b889fcc9149c21f239ea
|
||||
F LICENSE.md df5091916dbb40e6e9686186587125e1b2ff51f022cc334e886c19a0e9982724
|
||||
@ -1227,6 +1227,7 @@ F test/regexp1.test 497ea812f264d12b6198d6e50a76be4a1973a9d8
|
||||
F test/regexp2.test 40e894223b3d6672655481493f1be12012f2b33c
|
||||
F test/reindex.test 44edd3966b474468b823d481eafef0c305022254
|
||||
F test/releasetest.tcl 7712811e0f4e2f198ec786cb2e1352b3793d7395f48a3cceef0572d8823eb75e x
|
||||
F test/releasetest_data.tcl 1a89107e0f3be09efa9819367ffd96dbe9b82d571c03a75ba19444ca2432d05e
|
||||
F test/resetdb.test 8062cf10a09d8c048f8de7711e94571c38b38168db0e5877ba7561789e5eeb2b
|
||||
F test/resolver01.test f4022acafda7f4d40eca94dbf16bc5fc4ac30ceb
|
||||
F test/rollback.test 06680159bc6746d0f26276e339e3ae2f951c64812468308838e0a3362d911eaa
|
||||
@ -1649,6 +1650,8 @@ F test/walshared.test 0befc811dcf0b287efae21612304d15576e35417
|
||||
F test/walslow.test c05c68d4dc2700a982f89133ce103a1a84cc285f
|
||||
F test/walthread.test 14b20fcfa6ae152f5d8e12f5dc8a8a724b7ef189f5d8ef1e2ceab79f2af51747
|
||||
F test/walvfs.test c0faffda13d045a96dfc541347886bb1a3d6f3205857fc98e683edfab766ea88
|
||||
F test/wapp.tcl b440cd8cf57953d3a49e7ee81e6a18f18efdaf113b69f7d8482b0710a64566ec
|
||||
F test/wapptest.tcl 2475dd60ac518bedb9c1021e9fdeaa74f4356dd44ca569328b9e91e16a85f95e x
|
||||
F test/where.test 0607caa5a1fbfe7b93b95705981b463a3a0408038f22ae6e9dc11b36902b0e95
|
||||
F test/where2.test 478d2170637b9211f593120648858593bf2445a1
|
||||
F test/where3.test 2341a294e17193a6b1699ea7f192124a5286ca6acfcc3f4b06d16c931fbcda2c
|
||||
@ -1814,7 +1817,10 @@ F vsixtest/vsixtest.tcl 6a9a6ab600c25a91a7acc6293828957a386a8a93
|
||||
F vsixtest/vsixtest.vcxproj.data 2ed517e100c66dc455b492e1a33350c1b20fbcdc
|
||||
F vsixtest/vsixtest.vcxproj.filters 37e51ffedcdb064aad6ff33b6148725226cd608e
|
||||
F vsixtest/vsixtest_TemporaryKey.pfx e5b1b036facdb453873e7084e1cae9102ccc67a0
|
||||
P df58774e994bd306b1a2e1f259e7e4408f01c5b1dc104673698168bbf8a63ce5
|
||||
R 8f225a384e99d5cc8fcbc3b1a5a25930
|
||||
U drh
|
||||
Z 42970063c3d79b8d4bcc406c6a540b2c
|
||||
P 80704a16f6dbbeacc65fa36a3623df10292a28aeacf9e2c1d2891258479e3b89
|
||||
R 06080d39da3db81d6f3cab91a1103d90
|
||||
T *branch * wapptest
|
||||
T *sym-wapptest *
|
||||
T -sym-trunk *
|
||||
U dan
|
||||
Z 106b952a53453ebb55ee818fa0cbefd7
|
||||
|
||||
@ -1 +1 @@
|
||||
80704a16f6dbbeacc65fa36a3623df10292a28aeacf9e2c1d2891258479e3b89
|
||||
a4af0c2fee05aaa2e95ae6a5c847ff2d363e24f325f4ffdcf51bc264b9bf5e2d
|
||||
412
test/releasetest_data.tcl
Normal file
412
test/releasetest_data.tcl
Normal file
@ -0,0 +1,412 @@
|
||||
|
||||
# This file contains Configuration data used by "wapptest.tcl" and
|
||||
# "releasetest.tcl".
|
||||
#
|
||||
|
||||
# Omit comments (text between # and \n) in a long multi-line string.
|
||||
#
|
||||
proc strip_comments {in} {
|
||||
regsub -all {#[^\n]*\n} $in {} out
|
||||
return $out
|
||||
}
|
||||
|
||||
array set ::Configs [strip_comments {
|
||||
"Default" {
|
||||
-O2
|
||||
--disable-amalgamation --disable-shared
|
||||
--enable-session
|
||||
-DSQLITE_ENABLE_DESERIALIZE
|
||||
}
|
||||
"Sanitize" {
|
||||
CC=clang -fsanitize=undefined
|
||||
-DSQLITE_ENABLE_STAT4
|
||||
--enable-session
|
||||
}
|
||||
"Stdcall" {
|
||||
-DUSE_STDCALL=1
|
||||
-O2
|
||||
}
|
||||
"Have-Not" {
|
||||
# The "Have-Not" configuration sets all possible -UHAVE_feature options
|
||||
# in order to verify that the code works even on platforms that lack
|
||||
# these support services.
|
||||
-DHAVE_FDATASYNC=0
|
||||
-DHAVE_GMTIME_R=0
|
||||
-DHAVE_ISNAN=0
|
||||
-DHAVE_LOCALTIME_R=0
|
||||
-DHAVE_LOCALTIME_S=0
|
||||
-DHAVE_MALLOC_USABLE_SIZE=0
|
||||
-DHAVE_STRCHRNUL=0
|
||||
-DHAVE_USLEEP=0
|
||||
-DHAVE_UTIME=0
|
||||
}
|
||||
"Unlock-Notify" {
|
||||
-O2
|
||||
-DSQLITE_ENABLE_UNLOCK_NOTIFY
|
||||
-DSQLITE_THREADSAFE
|
||||
-DSQLITE_TCL_DEFAULT_FULLMUTEX=1
|
||||
}
|
||||
"User-Auth" {
|
||||
-O2
|
||||
-DSQLITE_USER_AUTHENTICATION=1
|
||||
}
|
||||
"Secure-Delete" {
|
||||
-O2
|
||||
-DSQLITE_SECURE_DELETE=1
|
||||
-DSQLITE_SOUNDEX=1
|
||||
}
|
||||
"Update-Delete-Limit" {
|
||||
-O2
|
||||
-DSQLITE_DEFAULT_FILE_FORMAT=4
|
||||
-DSQLITE_ENABLE_UPDATE_DELETE_LIMIT=1
|
||||
-DSQLITE_ENABLE_STMT_SCANSTATUS
|
||||
-DSQLITE_LIKE_DOESNT_MATCH_BLOBS
|
||||
-DSQLITE_ENABLE_CURSOR_HINTS
|
||||
--enable-json1
|
||||
}
|
||||
"Check-Symbols" {
|
||||
-DSQLITE_MEMDEBUG=1
|
||||
-DSQLITE_ENABLE_FTS3_PARENTHESIS=1
|
||||
-DSQLITE_ENABLE_FTS3=1
|
||||
-DSQLITE_ENABLE_RTREE=1
|
||||
-DSQLITE_ENABLE_MEMSYS5=1
|
||||
-DSQLITE_ENABLE_MEMSYS3=1
|
||||
-DSQLITE_ENABLE_COLUMN_METADATA=1
|
||||
-DSQLITE_ENABLE_UPDATE_DELETE_LIMIT=1
|
||||
-DSQLITE_SECURE_DELETE=1
|
||||
-DSQLITE_SOUNDEX=1
|
||||
-DSQLITE_ENABLE_ATOMIC_WRITE=1
|
||||
-DSQLITE_ENABLE_MEMORY_MANAGEMENT=1
|
||||
-DSQLITE_ENABLE_OVERSIZE_CELL_CHECK=1
|
||||
-DSQLITE_ENABLE_STAT4
|
||||
-DSQLITE_ENABLE_STMT_SCANSTATUS
|
||||
--enable-json1 --enable-fts5 --enable-session
|
||||
}
|
||||
"Debug-One" {
|
||||
--disable-shared
|
||||
-O2 -funsigned-char
|
||||
-DSQLITE_DEBUG=1
|
||||
-DSQLITE_MEMDEBUG=1
|
||||
-DSQLITE_MUTEX_NOOP=1
|
||||
-DSQLITE_TCL_DEFAULT_FULLMUTEX=1
|
||||
-DSQLITE_ENABLE_FTS3=1
|
||||
-DSQLITE_ENABLE_RTREE=1
|
||||
-DSQLITE_ENABLE_MEMSYS5=1
|
||||
-DSQLITE_ENABLE_COLUMN_METADATA=1
|
||||
-DSQLITE_ENABLE_STAT4
|
||||
-DSQLITE_ENABLE_HIDDEN_COLUMNS
|
||||
-DSQLITE_MAX_ATTACHED=125
|
||||
-DSQLITE_MUTATION_TEST
|
||||
--enable-fts5 --enable-json1
|
||||
}
|
||||
"Fast-One" {
|
||||
-O6
|
||||
-DSQLITE_ENABLE_FTS4=1
|
||||
-DSQLITE_ENABLE_RTREE=1
|
||||
-DSQLITE_ENABLE_STAT4
|
||||
-DSQLITE_ENABLE_RBU
|
||||
-DSQLITE_MAX_ATTACHED=125
|
||||
-DLONGDOUBLE_TYPE=double
|
||||
--enable-session
|
||||
}
|
||||
"Device-One" {
|
||||
-O2
|
||||
-DSQLITE_DEBUG=1
|
||||
-DSQLITE_DEFAULT_AUTOVACUUM=1
|
||||
-DSQLITE_DEFAULT_CACHE_SIZE=64
|
||||
-DSQLITE_DEFAULT_PAGE_SIZE=1024
|
||||
-DSQLITE_DEFAULT_TEMP_CACHE_SIZE=32
|
||||
-DSQLITE_DISABLE_LFS=1
|
||||
-DSQLITE_ENABLE_ATOMIC_WRITE=1
|
||||
-DSQLITE_ENABLE_IOTRACE=1
|
||||
-DSQLITE_ENABLE_MEMORY_MANAGEMENT=1
|
||||
-DSQLITE_MAX_PAGE_SIZE=4096
|
||||
-DSQLITE_OMIT_LOAD_EXTENSION=1
|
||||
-DSQLITE_OMIT_PROGRESS_CALLBACK=1
|
||||
-DSQLITE_OMIT_VIRTUALTABLE=1
|
||||
-DSQLITE_ENABLE_HIDDEN_COLUMNS
|
||||
-DSQLITE_TEMP_STORE=3
|
||||
--enable-json1
|
||||
}
|
||||
"Device-Two" {
|
||||
-DSQLITE_4_BYTE_ALIGNED_MALLOC=1
|
||||
-DSQLITE_DEFAULT_AUTOVACUUM=1
|
||||
-DSQLITE_DEFAULT_CACHE_SIZE=1000
|
||||
-DSQLITE_DEFAULT_LOCKING_MODE=0
|
||||
-DSQLITE_DEFAULT_PAGE_SIZE=1024
|
||||
-DSQLITE_DEFAULT_TEMP_CACHE_SIZE=1000
|
||||
-DSQLITE_DISABLE_LFS=1
|
||||
-DSQLITE_ENABLE_FTS3=1
|
||||
-DSQLITE_ENABLE_MEMORY_MANAGEMENT=1
|
||||
-DSQLITE_ENABLE_RTREE=1
|
||||
-DSQLITE_MAX_COMPOUND_SELECT=50
|
||||
-DSQLITE_MAX_PAGE_SIZE=32768
|
||||
-DSQLITE_OMIT_TRACE=1
|
||||
-DSQLITE_TEMP_STORE=3
|
||||
-DSQLITE_THREADSAFE=2
|
||||
-DSQLITE_ENABLE_DESERIALIZE=1
|
||||
--enable-json1 --enable-fts5 --enable-session
|
||||
}
|
||||
"Locking-Style" {
|
||||
-O2
|
||||
-DSQLITE_ENABLE_LOCKING_STYLE=1
|
||||
}
|
||||
"Apple" {
|
||||
-Os
|
||||
-DHAVE_GMTIME_R=1
|
||||
-DHAVE_ISNAN=1
|
||||
-DHAVE_LOCALTIME_R=1
|
||||
-DHAVE_PREAD=1
|
||||
-DHAVE_PWRITE=1
|
||||
-DHAVE_USLEEP=1
|
||||
-DHAVE_USLEEP=1
|
||||
-DHAVE_UTIME=1
|
||||
-DSQLITE_DEFAULT_CACHE_SIZE=1000
|
||||
-DSQLITE_DEFAULT_CKPTFULLFSYNC=1
|
||||
-DSQLITE_DEFAULT_MEMSTATUS=1
|
||||
-DSQLITE_DEFAULT_PAGE_SIZE=1024
|
||||
-DSQLITE_DISABLE_PAGECACHE_OVERFLOW_STATS=1
|
||||
-DSQLITE_ENABLE_API_ARMOR=1
|
||||
-DSQLITE_ENABLE_AUTO_PROFILE=1
|
||||
-DSQLITE_ENABLE_FLOCKTIMEOUT=1
|
||||
-DSQLITE_ENABLE_FTS3=1
|
||||
-DSQLITE_ENABLE_FTS3_PARENTHESIS=1
|
||||
-DSQLITE_ENABLE_FTS3_TOKENIZER=1
|
||||
if:os=="Darwin" -DSQLITE_ENABLE_LOCKING_STYLE=1
|
||||
-DSQLITE_ENABLE_PERSIST_WAL=1
|
||||
-DSQLITE_ENABLE_PURGEABLE_PCACHE=1
|
||||
-DSQLITE_ENABLE_RTREE=1
|
||||
-DSQLITE_ENABLE_SNAPSHOT=1
|
||||
# -DSQLITE_ENABLE_SQLLOG=1
|
||||
-DSQLITE_ENABLE_UPDATE_DELETE_LIMIT=1
|
||||
-DSQLITE_MAX_LENGTH=2147483645
|
||||
-DSQLITE_MAX_VARIABLE_NUMBER=500000
|
||||
# -DSQLITE_MEMDEBUG=1
|
||||
-DSQLITE_NO_SYNC=1
|
||||
-DSQLITE_OMIT_AUTORESET=1
|
||||
-DSQLITE_OMIT_LOAD_EXTENSION=1
|
||||
-DSQLITE_PREFER_PROXY_LOCKING=1
|
||||
-DSQLITE_SERIES_CONSTRAINT_VERIFY=1
|
||||
-DSQLITE_THREADSAFE=2
|
||||
-DSQLITE_USE_URI=1
|
||||
-DSQLITE_WRITE_WALFRAME_PREBUFFERED=1
|
||||
-DUSE_GUARDED_FD=1
|
||||
-DUSE_PREAD=1
|
||||
--enable-json1 --enable-fts5
|
||||
}
|
||||
"Extra-Robustness" {
|
||||
-DSQLITE_ENABLE_OVERSIZE_CELL_CHECK=1
|
||||
-DSQLITE_MAX_ATTACHED=62
|
||||
}
|
||||
"Devkit" {
|
||||
-DSQLITE_DEFAULT_FILE_FORMAT=4
|
||||
-DSQLITE_MAX_ATTACHED=30
|
||||
-DSQLITE_ENABLE_COLUMN_METADATA
|
||||
-DSQLITE_ENABLE_FTS4
|
||||
-DSQLITE_ENABLE_FTS5
|
||||
-DSQLITE_ENABLE_FTS4_PARENTHESIS
|
||||
-DSQLITE_DISABLE_FTS4_DEFERRED
|
||||
-DSQLITE_ENABLE_RTREE
|
||||
--enable-json1 --enable-fts5
|
||||
}
|
||||
"No-lookaside" {
|
||||
-DSQLITE_TEST_REALLOC_STRESS=1
|
||||
-DSQLITE_OMIT_LOOKASIDE=1
|
||||
-DHAVE_USLEEP=1
|
||||
}
|
||||
"Valgrind" {
|
||||
-DSQLITE_ENABLE_STAT4
|
||||
-DSQLITE_ENABLE_FTS4
|
||||
-DSQLITE_ENABLE_RTREE
|
||||
-DSQLITE_ENABLE_HIDDEN_COLUMNS
|
||||
--enable-json1
|
||||
}
|
||||
|
||||
# The next group of configurations are used only by the
|
||||
# Failure-Detection platform. They are all the same, but we need
|
||||
# different names for them all so that they results appear in separate
|
||||
# subdirectories.
|
||||
#
|
||||
Fail0 {-O0}
|
||||
Fail2 {-O0}
|
||||
Fail3 {-O0}
|
||||
Fail4 {-O0}
|
||||
FuzzFail1 {-O0}
|
||||
FuzzFail2 {-O0}
|
||||
}]
|
||||
|
||||
array set ::Platforms [strip_comments {
|
||||
Linux-x86_64 {
|
||||
"Check-Symbols" checksymbols
|
||||
"Fast-One" "fuzztest test"
|
||||
"Debug-One" "mptest test"
|
||||
"Have-Not" test
|
||||
"Secure-Delete" test
|
||||
"Unlock-Notify" "QUICKTEST_INCLUDE=notify2.test test"
|
||||
"User-Auth" tcltest
|
||||
"Update-Delete-Limit" test
|
||||
"Extra-Robustness" test
|
||||
"Device-Two" test
|
||||
"No-lookaside" test
|
||||
"Devkit" test
|
||||
"Apple" test
|
||||
"Sanitize" {QUICKTEST_OMIT=func4.test,nan.test test}
|
||||
"Device-One" fulltest
|
||||
"Default" "threadtest fulltest"
|
||||
"Valgrind" valgrindtest
|
||||
}
|
||||
Linux-i686 {
|
||||
"Devkit" test
|
||||
"Have-Not" test
|
||||
"Unlock-Notify" "QUICKTEST_INCLUDE=notify2.test test"
|
||||
"Device-One" test
|
||||
"Device-Two" test
|
||||
"Default" "threadtest fulltest"
|
||||
}
|
||||
Darwin-i386 {
|
||||
"Locking-Style" "mptest test"
|
||||
"Have-Not" test
|
||||
"Apple" "threadtest fulltest"
|
||||
}
|
||||
Darwin-x86_64 {
|
||||
"Locking-Style" "mptest test"
|
||||
"Have-Not" test
|
||||
"Apple" "threadtest fulltest"
|
||||
}
|
||||
"Windows NT-intel" {
|
||||
"Stdcall" test
|
||||
"Have-Not" test
|
||||
"Default" "mptest fulltestonly"
|
||||
}
|
||||
"Windows NT-amd64" {
|
||||
"Stdcall" test
|
||||
"Have-Not" test
|
||||
"Default" "mptest fulltestonly"
|
||||
}
|
||||
|
||||
# The Failure-Detection platform runs various tests that deliberately
|
||||
# fail. This is used as a test of this script to verify that this script
|
||||
# correctly identifies failures.
|
||||
#
|
||||
Failure-Detection {
|
||||
Fail0 "TEST_FAILURE=0 test"
|
||||
Sanitize "TEST_FAILURE=1 test"
|
||||
Fail2 "TEST_FAILURE=2 valgrindtest"
|
||||
Fail3 "TEST_FAILURE=3 valgrindtest"
|
||||
Fail4 "TEST_FAILURE=4 test"
|
||||
FuzzFail1 "TEST_FAILURE=5 test"
|
||||
FuzzFail2 "TEST_FAILURE=5 valgrindtest"
|
||||
}
|
||||
}]
|
||||
|
||||
proc make_test_suite {msvc withtcl name testtarget config} {
|
||||
|
||||
# Tcl variable $opts is used to build up the value used to set the
|
||||
# OPTS Makefile variable. Variable $cflags holds the value for
|
||||
# CFLAGS. The makefile will pass OPTS to both gcc and lemon, but
|
||||
# CFLAGS is only passed to gcc.
|
||||
#
|
||||
set makeOpts ""
|
||||
set cflags [expr {$msvc ? "-Zi" : "-g"}]
|
||||
set opts ""
|
||||
set title ${name}($testtarget)
|
||||
set configOpts $withtcl
|
||||
set skip 0
|
||||
|
||||
regsub -all {#[^\n]*\n} $config \n config
|
||||
foreach arg $config {
|
||||
if {$skip} {
|
||||
set skip 0
|
||||
continue
|
||||
}
|
||||
if {[regexp {^-[UD]} $arg]} {
|
||||
lappend opts $arg
|
||||
} elseif {[regexp {^[A-Z]+=} $arg]} {
|
||||
lappend testtarget $arg
|
||||
} elseif {[regexp {^if:([a-z]+)(.*)} $arg all key tail]} {
|
||||
# Arguments of the form 'if:os=="Linux"' will cause the subsequent
|
||||
# argument to be skipped if the $tcl_platform(os) is not "Linux", for
|
||||
# example...
|
||||
set skip [expr !(\$::tcl_platform($key)$tail)]
|
||||
} elseif {[regexp {^--(enable|disable)-} $arg]} {
|
||||
if {$msvc} {
|
||||
if {$arg eq "--disable-amalgamation"} {
|
||||
lappend makeOpts USE_AMALGAMATION=0
|
||||
continue
|
||||
}
|
||||
if {$arg eq "--disable-shared"} {
|
||||
lappend makeOpts USE_CRT_DLL=0 DYNAMIC_SHELL=0
|
||||
continue
|
||||
}
|
||||
if {$arg eq "--enable-fts5"} {
|
||||
lappend opts -DSQLITE_ENABLE_FTS5
|
||||
continue
|
||||
}
|
||||
if {$arg eq "--enable-json1"} {
|
||||
lappend opts -DSQLITE_ENABLE_JSON1
|
||||
continue
|
||||
}
|
||||
if {$arg eq "--enable-shared"} {
|
||||
lappend makeOpts USE_CRT_DLL=1 DYNAMIC_SHELL=1
|
||||
continue
|
||||
}
|
||||
}
|
||||
lappend configOpts $arg
|
||||
} else {
|
||||
if {$msvc} {
|
||||
if {$arg eq "-g"} {
|
||||
lappend cflags -Zi
|
||||
continue
|
||||
}
|
||||
if {[regexp -- {^-O(\d+)$} $arg all level]} then {
|
||||
lappend makeOpts OPTIMIZATIONS=$level
|
||||
continue
|
||||
}
|
||||
}
|
||||
lappend cflags $arg
|
||||
}
|
||||
}
|
||||
|
||||
# Disable sync to make testing faster.
|
||||
#
|
||||
lappend opts -DSQLITE_NO_SYNC=1
|
||||
|
||||
# Some configurations already set HAVE_USLEEP; in that case, skip it.
|
||||
#
|
||||
if {[lsearch -regexp $opts {^-DHAVE_USLEEP(?:=|$)}]==-1} {
|
||||
lappend opts -DHAVE_USLEEP=1
|
||||
}
|
||||
|
||||
# Add the define for this platform.
|
||||
#
|
||||
if {$::tcl_platform(platform)=="windows"} {
|
||||
lappend opts -DSQLITE_OS_WIN=1
|
||||
} else {
|
||||
lappend opts -DSQLITE_OS_UNIX=1
|
||||
}
|
||||
|
||||
# Set the sub-directory to use.
|
||||
#
|
||||
set dir [string tolower [string map {- _ " " _} $name]]
|
||||
|
||||
# Join option lists into strings, using space as delimiter.
|
||||
#
|
||||
set makeOpts [join $makeOpts " "]
|
||||
set cflags [join $cflags " "]
|
||||
set opts [join $opts " "]
|
||||
|
||||
return [list $title $dir $configOpts $testtarget $makeOpts $cflags $opts]
|
||||
}
|
||||
|
||||
# Configuration verification: Check that each entry in the list of configs
|
||||
# specified for each platforms exists.
|
||||
#
|
||||
foreach {key value} [array get ::Platforms] {
|
||||
foreach {v t} $value {
|
||||
if {0==[info exists ::Configs($v)]} {
|
||||
puts stderr "No such configuration: \"$v\""
|
||||
exit -1
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
987
test/wapp.tcl
Normal file
987
test/wapp.tcl
Normal file
@ -0,0 +1,987 @@
|
||||
# Copyright (c) 2017 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.
|
||||
#
|
||||
#---------------------------------------------------------------------------
|
||||
#
|
||||
# Design rules:
|
||||
#
|
||||
# (1) All identifiers in the global namespace begin with "wapp"
|
||||
#
|
||||
# (2) Indentifiers intended for internal use only begin with "wappInt"
|
||||
#
|
||||
package require Tcl 8.6
|
||||
|
||||
# Add text to the end of the HTTP reply. No interpretation or transformation
|
||||
# of the text is performs. The argument should be enclosed within {...}
|
||||
#
|
||||
proc wapp {txt} {
|
||||
global wapp
|
||||
dict append wapp .reply $txt
|
||||
}
|
||||
|
||||
# Add text to the page under construction. Do no escaping on the text.
|
||||
#
|
||||
# Though "unsafe" in general, there are uses for this kind of thing.
|
||||
# For example, if you want to return the complete, unmodified content of
|
||||
# a file:
|
||||
#
|
||||
# set fd [open content.html rb]
|
||||
# wapp-unsafe [read $fd]
|
||||
# close $fd
|
||||
#
|
||||
# You could do the same thing using ordinary "wapp" instead of "wapp-unsafe".
|
||||
# The difference is that wapp-safety-check will complain about the misuse
|
||||
# of "wapp", but it assumes that the person who write "wapp-unsafe" understands
|
||||
# the risks.
|
||||
#
|
||||
# Though occasionally necessary, the use of this interface should be minimized.
|
||||
#
|
||||
proc wapp-unsafe {txt} {
|
||||
global wapp
|
||||
dict append wapp .reply $txt
|
||||
}
|
||||
|
||||
# Add text to the end of the reply under construction. The following
|
||||
# substitutions are made:
|
||||
#
|
||||
# %html(...) Escape text for inclusion in HTML
|
||||
# %url(...) Escape text for use as a URL
|
||||
# %qp(...) Escape text for use as a URI query parameter
|
||||
# %string(...) Escape text for use within a JSON string
|
||||
# %unsafe(...) No transformations of the text
|
||||
#
|
||||
# The substitutions above terminate at the first ")" character. If the
|
||||
# text of the TCL string in ... contains ")" characters itself, use instead:
|
||||
#
|
||||
# %html%(...)%
|
||||
# %url%(...)%
|
||||
# %qp%(...)%
|
||||
# %string%(...)%
|
||||
# %unsafe%(...)%
|
||||
#
|
||||
# In other words, use "%(...)%" instead of "(...)" to include the TCL string
|
||||
# to substitute.
|
||||
#
|
||||
# The %unsafe substitution should be avoided whenever possible, obviously.
|
||||
# In addition to the substitutions above, the text also does backslash
|
||||
# escapes.
|
||||
#
|
||||
# The wapp-trim proc works the same as wapp-subst except that it also removes
|
||||
# whitespace from the left margin, so that the generated HTML/CSS/Javascript
|
||||
# does not appear to be indented when delivered to the client web browser.
|
||||
#
|
||||
if {$tcl_version>=8.7} {
|
||||
proc wapp-subst {txt} {
|
||||
global wapp
|
||||
regsub -all -command \
|
||||
{%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt wappInt-enc txt
|
||||
dict append wapp .reply [subst -novariables -nocommand $txt]
|
||||
}
|
||||
proc wapp-trim {txt} {
|
||||
global wapp
|
||||
regsub -all {\n\s+} [string trim $txt] \n txt
|
||||
regsub -all -command \
|
||||
{%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt wappInt-enc txt
|
||||
dict append wapp .reply [subst -novariables -nocommand $txt]
|
||||
}
|
||||
proc wappInt-enc {all mode nu1 txt} {
|
||||
return [uplevel 2 "wappInt-enc-$mode \"$txt\""]
|
||||
}
|
||||
} else {
|
||||
proc wapp-subst {txt} {
|
||||
global wapp
|
||||
regsub -all {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt \
|
||||
{[wappInt-enc-\1 "\3"]} txt
|
||||
dict append wapp .reply [uplevel 1 [list subst -novariables $txt]]
|
||||
}
|
||||
proc wapp-trim {txt} {
|
||||
global wapp
|
||||
regsub -all {\n\s+} [string trim $txt] \n txt
|
||||
regsub -all {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt \
|
||||
{[wappInt-enc-\1 "\3"]} txt
|
||||
dict append wapp .reply [uplevel 1 [list subst -novariables $txt]]
|
||||
}
|
||||
}
|
||||
|
||||
# There must be a wappInt-enc-NAME routine for each possible substitution
|
||||
# in wapp-subst. Thus there are routines for "html", "url", "qp", and "unsafe".
|
||||
#
|
||||
# wappInt-enc-html Escape text so that it is safe to use in the
|
||||
# body of an HTML document.
|
||||
#
|
||||
# wappInt-enc-url Escape text so that it is safe to pass as an
|
||||
# argument to href= and src= attributes in HTML.
|
||||
#
|
||||
# wappInt-enc-qp Escape text so that it is safe to use as the
|
||||
# value of a query parameter in a URL or in
|
||||
# post data or in a cookie.
|
||||
#
|
||||
# wappInt-enc-string Escape ", ', \, and < for using inside of a
|
||||
# javascript string literal. The < character
|
||||
# is escaped to prevent "</script>" from causing
|
||||
# problems in embedded javascript.
|
||||
#
|
||||
# wappInt-enc-unsafe Perform no encoding at all. Unsafe.
|
||||
#
|
||||
proc wappInt-enc-html {txt} {
|
||||
return [string map {& & < < > > \" " \\ \} $txt]
|
||||
}
|
||||
proc wappInt-enc-unsafe {txt} {
|
||||
return $txt
|
||||
}
|
||||
proc wappInt-enc-url {s} {
|
||||
if {[regsub -all {[^-{}@~?=#_.:/a-zA-Z0-9]} $s {[wappInt-%HHchar {&}]} s]} {
|
||||
set s [subst -novar -noback $s]
|
||||
}
|
||||
if {[regsub -all {[{}]} $s {[wappInt-%HHchar \\&]} s]} {
|
||||
set s [subst -novar -noback $s]
|
||||
}
|
||||
return $s
|
||||
}
|
||||
proc wappInt-enc-qp {s} {
|
||||
if {[regsub -all {[^-{}_.a-zA-Z0-9]} $s {[wappInt-%HHchar {&}]} s]} {
|
||||
set s [subst -novar -noback $s]
|
||||
}
|
||||
if {[regsub -all {[{}]} $s {[wappInt-%HHchar \\&]} s]} {
|
||||
set s [subst -novar -noback $s]
|
||||
}
|
||||
return $s
|
||||
}
|
||||
proc wappInt-enc-string {s} {
|
||||
return [string map {\\ \\\\ \" \\\" ' \\' < \\u003c} $s]
|
||||
}
|
||||
|
||||
# This is a helper routine for wappInt-enc-url and wappInt-enc-qp. It returns
|
||||
# an appropriate %HH encoding for the single character c. If c is a unicode
|
||||
# character, then this routine might return multiple bytes: %HH%HH%HH
|
||||
#
|
||||
proc wappInt-%HHchar {c} {
|
||||
if {$c==" "} {return +}
|
||||
return [regsub -all .. [binary encode hex [encoding convertto utf-8 $c]] {%&}]
|
||||
}
|
||||
|
||||
|
||||
# Undo the www-url-encoded format.
|
||||
#
|
||||
# HT: This code stolen from ncgi.tcl
|
||||
#
|
||||
proc wappInt-decode-url {str} {
|
||||
set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str]
|
||||
regsub -all -- \
|
||||
{%([Ee][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \
|
||||
$str {[encoding convertfrom utf-8 [binary decode hex \1\2\3]]} str
|
||||
regsub -all -- \
|
||||
{%([CDcd][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \
|
||||
$str {[encoding convertfrom utf-8 [binary decode hex \1\2]]} str
|
||||
regsub -all -- {%([0-7][A-Fa-f0-9])} $str {\\u00\1} str
|
||||
return [subst -novar $str]
|
||||
}
|
||||
|
||||
# Reset the document back to an empty string.
|
||||
#
|
||||
proc wapp-reset {} {
|
||||
global wapp
|
||||
dict set wapp .reply {}
|
||||
}
|
||||
|
||||
# Change the mime-type of the result document.
|
||||
#
|
||||
proc wapp-mimetype {x} {
|
||||
global wapp
|
||||
dict set wapp .mimetype $x
|
||||
}
|
||||
|
||||
# Change the reply code.
|
||||
#
|
||||
proc wapp-reply-code {x} {
|
||||
global wapp
|
||||
dict set wapp .reply-code $x
|
||||
}
|
||||
|
||||
# Set a cookie
|
||||
#
|
||||
proc wapp-set-cookie {name value} {
|
||||
global wapp
|
||||
dict lappend wapp .new-cookies $name $value
|
||||
}
|
||||
|
||||
# Unset a cookie
|
||||
#
|
||||
proc wapp-clear-cookie {name} {
|
||||
wapp-set-cookie $name {}
|
||||
}
|
||||
|
||||
# Add extra entries to the reply header
|
||||
#
|
||||
proc wapp-reply-extra {name value} {
|
||||
global wapp
|
||||
dict lappend wapp .reply-extra $name $value
|
||||
}
|
||||
|
||||
# Specifies how the web-page under construction should be cached.
|
||||
# The argument should be one of:
|
||||
#
|
||||
# no-cache
|
||||
# max-age=N (for some integer number of seconds, N)
|
||||
# private,max-age=N
|
||||
#
|
||||
proc wapp-cache-control {x} {
|
||||
wapp-reply-extra Cache-Control $x
|
||||
}
|
||||
|
||||
# Redirect to a different web page
|
||||
#
|
||||
proc wapp-redirect {uri} {
|
||||
wapp-reply-code {307 Redirect}
|
||||
wapp-reply-extra Location $uri
|
||||
}
|
||||
|
||||
# Return the value of a wapp parameter
|
||||
#
|
||||
proc wapp-param {name {dflt {}}} {
|
||||
global wapp
|
||||
if {![dict exists $wapp $name]} {return $dflt}
|
||||
return [dict get $wapp $name]
|
||||
}
|
||||
|
||||
# Return true if a and only if the wapp parameter $name exists
|
||||
#
|
||||
proc wapp-param-exists {name} {
|
||||
global wapp
|
||||
return [dict exists $wapp $name]
|
||||
}
|
||||
|
||||
# Set the value of a wapp parameter
|
||||
#
|
||||
proc wapp-set-param {name value} {
|
||||
global wapp
|
||||
dict set wapp $name $value
|
||||
}
|
||||
|
||||
# Return all parameter names that match the GLOB pattern, or all
|
||||
# names if the GLOB pattern is omitted.
|
||||
#
|
||||
proc wapp-param-list {{glob {*}}} {
|
||||
global wapp
|
||||
return [dict keys $wapp $glob]
|
||||
}
|
||||
|
||||
# By default, Wapp does not decode query parameters and POST parameters
|
||||
# for cross-origin requests. This is a security restriction, designed to
|
||||
# help prevent cross-site request forgery (CSRF) attacks.
|
||||
#
|
||||
# As a consequence of this restriction, URLs for sites generated by Wapp
|
||||
# that contain query parameters will not work as URLs found in other
|
||||
# websites. You cannot create a link from a second website into a Wapp
|
||||
# website if the link contains query planner, by default.
|
||||
#
|
||||
# Of course, it is sometimes desirable to allow query parameters on external
|
||||
# links. For URLs for which this is safe, the application should invoke
|
||||
# wapp-allow-xorigin-params. This procedure tells Wapp that it is safe to
|
||||
# go ahead and decode the query parameters even for cross-site requests.
|
||||
#
|
||||
# In other words, for Wapp security is the default setting. Individual pages
|
||||
# need to actively disable the cross-site request security if those pages
|
||||
# are safe for cross-site access.
|
||||
#
|
||||
proc wapp-allow-xorigin-params {} {
|
||||
global wapp
|
||||
if {![dict exists $wapp .qp] && ![dict get $wapp SAME_ORIGIN]} {
|
||||
wappInt-decode-query-params
|
||||
}
|
||||
}
|
||||
|
||||
# Set the content-security-policy.
|
||||
#
|
||||
# The default content-security-policy is very strict: "default-src 'self'"
|
||||
# The default policy prohibits the use of in-line javascript or CSS.
|
||||
#
|
||||
# Provide an alternative CSP as the argument. Or use "off" to disable
|
||||
# the CSP completely.
|
||||
#
|
||||
proc wapp-content-security-policy {val} {
|
||||
global wapp
|
||||
if {$val=="off"} {
|
||||
dict unset wapp .csp
|
||||
} else {
|
||||
dict set wapp .csp $val
|
||||
}
|
||||
}
|
||||
|
||||
# Examine the bodys of all procedures in this program looking for
|
||||
# unsafe calls to various Wapp interfaces. Return a text string
|
||||
# containing warnings. Return an empty string if all is ok.
|
||||
#
|
||||
# This routine is advisory only. It misses some constructs that are
|
||||
# dangerous and flags others that are safe.
|
||||
#
|
||||
proc wapp-safety-check {} {
|
||||
set res {}
|
||||
foreach p [info procs] {
|
||||
set ln 0
|
||||
foreach x [split [info body $p] \n] {
|
||||
incr ln
|
||||
if {[regexp {^[ \t]*wapp[ \t]+([^\n]+)} $x all tail]
|
||||
&& [string index $tail 0]!="\173"
|
||||
&& [regexp {[[$]} $tail]
|
||||
} {
|
||||
append res "$p:$ln: unsafe \"wapp\" call: \"[string trim $x]\"\n"
|
||||
}
|
||||
if {[regexp {^[ \t]*wapp-(subst|trim)[ \t]+[^\173]} $x all cx]} {
|
||||
append res "$p:$ln: unsafe \"wapp-$cx\" call: \"[string trim $x]\"\n"
|
||||
}
|
||||
}
|
||||
}
|
||||
return $res
|
||||
}
|
||||
|
||||
# Return a string that descripts the current environment. Applications
|
||||
# might find this useful for debugging.
|
||||
#
|
||||
proc wapp-debug-env {} {
|
||||
global wapp
|
||||
set out {}
|
||||
foreach var [lsort [dict keys $wapp]] {
|
||||
if {[string index $var 0]=="."} continue
|
||||
append out "$var = [list [dict get $wapp $var]]\n"
|
||||
}
|
||||
append out "\[pwd\] = [list [pwd]]\n"
|
||||
return $out
|
||||
}
|
||||
|
||||
# Tracing function for each HTTP request. This is overridden by wapp-start
|
||||
# if tracing is enabled.
|
||||
#
|
||||
proc wappInt-trace {} {}
|
||||
|
||||
# Start up a listening socket. Arrange to invoke wappInt-new-connection
|
||||
# for each inbound HTTP connection.
|
||||
#
|
||||
# port Listen on this TCP port. 0 means to select a port
|
||||
# that is not currently in use
|
||||
#
|
||||
# wappmode One of "scgi", "remote-scgi", "server", or "local".
|
||||
#
|
||||
# fromip If not {}, then reject all requests from IP addresses
|
||||
# other than $fromip
|
||||
#
|
||||
proc wappInt-start-listener {port wappmode fromip} {
|
||||
if {[string match *scgi $wappmode]} {
|
||||
set type SCGI
|
||||
set server [list wappInt-new-connection \
|
||||
wappInt-scgi-readable $wappmode $fromip]
|
||||
} else {
|
||||
set type HTTP
|
||||
set server [list wappInt-new-connection \
|
||||
wappInt-http-readable $wappmode $fromip]
|
||||
}
|
||||
if {$wappmode=="local" || $wappmode=="scgi"} {
|
||||
set x [socket -server $server -myaddr 127.0.0.1 $port]
|
||||
} else {
|
||||
set x [socket -server $server $port]
|
||||
}
|
||||
set coninfo [chan configure $x -sockname]
|
||||
set port [lindex $coninfo 2]
|
||||
if {$wappmode=="local"} {
|
||||
wappInt-start-browser http://127.0.0.1:$port/
|
||||
} elseif {$fromip!=""} {
|
||||
puts "Listening for $type requests on TCP port $port from IP $fromip"
|
||||
} else {
|
||||
puts "Listening for $type requests on TCP port $port"
|
||||
}
|
||||
}
|
||||
|
||||
# Start a web-browser and point it at $URL
|
||||
#
|
||||
proc wappInt-start-browser {url} {
|
||||
global tcl_platform
|
||||
if {$tcl_platform(platform)=="windows"} {
|
||||
exec cmd /c start $url &
|
||||
} elseif {$tcl_platform(os)=="Darwin"} {
|
||||
exec open $url &
|
||||
} elseif {[catch {exec xdg-open $url}]} {
|
||||
exec firefox $url &
|
||||
}
|
||||
}
|
||||
|
||||
# This routine is a "socket -server" callback. The $chan, $ip, and $port
|
||||
# arguments are added by the socket command.
|
||||
#
|
||||
# Arrange to invoke $callback when content is available on the new socket.
|
||||
# The $callback will process inbound HTTP or SCGI content. Reject the
|
||||
# request if $fromip is not an empty string and does not match $ip.
|
||||
#
|
||||
proc wappInt-new-connection {callback wappmode fromip chan ip port} {
|
||||
upvar #0 wappInt-$chan W
|
||||
if {$fromip!="" && ![string match $fromip $ip]} {
|
||||
close $chan
|
||||
return
|
||||
}
|
||||
set W [dict create REMOTE_ADDR $ip REMOTE_PORT $port WAPP_MODE $wappmode \
|
||||
.header {}]
|
||||
fconfigure $chan -blocking 0 -translation binary
|
||||
fileevent $chan readable [list $callback $chan]
|
||||
}
|
||||
|
||||
# Close an input channel
|
||||
#
|
||||
proc wappInt-close-channel {chan} {
|
||||
if {$chan=="stdout"} {
|
||||
# This happens after completing a CGI request
|
||||
exit 0
|
||||
} else {
|
||||
unset ::wappInt-$chan
|
||||
close $chan
|
||||
}
|
||||
}
|
||||
|
||||
# Process new text received on an inbound HTTP request
|
||||
#
|
||||
proc wappInt-http-readable {chan} {
|
||||
if {[catch [list wappInt-http-readable-unsafe $chan] msg]} {
|
||||
puts stderr "$msg\n$::errorInfo"
|
||||
wappInt-close-channel $chan
|
||||
}
|
||||
}
|
||||
proc wappInt-http-readable-unsafe {chan} {
|
||||
upvar #0 wappInt-$chan W wapp wapp
|
||||
if {![dict exists $W .toread]} {
|
||||
# If the .toread key is not set, that means we are still reading
|
||||
# the header
|
||||
set line [string trimright [gets $chan]]
|
||||
set n [string length $line]
|
||||
if {$n>0} {
|
||||
if {[dict get $W .header]=="" || [regexp {^\s+} $line]} {
|
||||
dict append W .header $line
|
||||
} else {
|
||||
dict append W .header \n$line
|
||||
}
|
||||
if {[string length [dict get $W .header]]>100000} {
|
||||
error "HTTP request header too big - possible DOS attack"
|
||||
}
|
||||
} elseif {$n==0} {
|
||||
# We have reached the blank line that terminates the header.
|
||||
global argv0
|
||||
set a0 [file normalize $argv0]
|
||||
dict set W SCRIPT_FILENAME $a0
|
||||
dict set W DOCUMENT_ROOT [file dir $a0]
|
||||
if {[wappInt-parse-header $chan]} {
|
||||
catch {close $chan}
|
||||
return
|
||||
}
|
||||
set len 0
|
||||
if {[dict exists $W CONTENT_LENGTH]} {
|
||||
set len [dict get $W CONTENT_LENGTH]
|
||||
}
|
||||
if {$len>0} {
|
||||
# Still need to read the query content
|
||||
dict set W .toread $len
|
||||
} else {
|
||||
# There is no query content, so handle the request immediately
|
||||
set wapp $W
|
||||
wappInt-handle-request $chan 0
|
||||
}
|
||||
}
|
||||
} else {
|
||||
# If .toread is set, that means we are reading the query content.
|
||||
# Continue reading until .toread reaches zero.
|
||||
set got [read $chan [dict get $W .toread]]
|
||||
dict append W CONTENT $got
|
||||
dict set W .toread [expr {[dict get $W .toread]-[string length $got]}]
|
||||
if {[dict get $W .toread]<=0} {
|
||||
# Handle the request as soon as all the query content is received
|
||||
set wapp $W
|
||||
wappInt-handle-request $chan 0
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Decode the HTTP request header.
|
||||
#
|
||||
# This routine is always running inside of a [catch], so if
|
||||
# any problems arise, simply raise an error.
|
||||
#
|
||||
proc wappInt-parse-header {chan} {
|
||||
upvar #0 wappInt-$chan W
|
||||
set hdr [split [dict get $W .header] \n]
|
||||
if {$hdr==""} {return 1}
|
||||
set req [lindex $hdr 0]
|
||||
dict set W REQUEST_METHOD [set method [lindex $req 0]]
|
||||
if {[lsearch {GET HEAD POST} $method]<0} {
|
||||
error "unsupported request method: \"[dict get $W REQUEST_METHOD]\""
|
||||
}
|
||||
set uri [lindex $req 1]
|
||||
set split_uri [split $uri ?]
|
||||
set uri0 [lindex $split_uri 0]
|
||||
if {![regexp {^/[-.a-z0-9_/]*$} $uri0]} {
|
||||
error "invalid request uri: \"$uri0\""
|
||||
}
|
||||
dict set W REQUEST_URI $uri0
|
||||
dict set W PATH_INFO $uri0
|
||||
set uri1 [lindex $split_uri 1]
|
||||
dict set W QUERY_STRING $uri1
|
||||
set n [llength $hdr]
|
||||
for {set i 1} {$i<$n} {incr i} {
|
||||
set x [lindex $hdr $i]
|
||||
if {![regexp {^(.+): +(.*)$} $x all name value]} {
|
||||
error "invalid header line: \"$x\""
|
||||
}
|
||||
set name [string toupper $name]
|
||||
switch -- $name {
|
||||
REFERER {set name HTTP_REFERER}
|
||||
USER-AGENT {set name HTTP_USER_AGENT}
|
||||
CONTENT-LENGTH {set name CONTENT_LENGTH}
|
||||
CONTENT-TYPE {set name CONTENT_TYPE}
|
||||
HOST {set name HTTP_HOST}
|
||||
COOKIE {set name HTTP_COOKIE}
|
||||
ACCEPT-ENCODING {set name HTTP_ACCEPT_ENCODING}
|
||||
default {set name .hdr:$name}
|
||||
}
|
||||
dict set W $name $value
|
||||
}
|
||||
return 0
|
||||
}
|
||||
|
||||
# Decode the QUERY_STRING parameters from a GET request or the
|
||||
# application/x-www-form-urlencoded CONTENT from a POST request.
|
||||
#
|
||||
# This routine sets the ".qp" element of the ::wapp dict as a signal
|
||||
# that query parameters have already been decoded.
|
||||
#
|
||||
proc wappInt-decode-query-params {} {
|
||||
global wapp
|
||||
dict set wapp .qp 1
|
||||
if {[dict exists $wapp QUERY_STRING]} {
|
||||
foreach qterm [split [dict get $wapp QUERY_STRING] &] {
|
||||
set qsplit [split $qterm =]
|
||||
set nm [lindex $qsplit 0]
|
||||
if {[regexp {^[a-z][a-z0-9]*$} $nm]} {
|
||||
dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]]
|
||||
}
|
||||
}
|
||||
}
|
||||
if {[dict exists $wapp CONTENT_TYPE] && [dict exists $wapp CONTENT]} {
|
||||
set ctype [dict get $wapp CONTENT_TYPE]
|
||||
if {$ctype=="application/x-www-form-urlencoded"} {
|
||||
foreach qterm [split [string trim [dict get $wapp CONTENT]] &] {
|
||||
set qsplit [split $qterm =]
|
||||
set nm [lindex $qsplit 0]
|
||||
if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} {
|
||||
dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]]
|
||||
}
|
||||
}
|
||||
} elseif {[string match multipart/form-data* $ctype]} {
|
||||
regexp {^(.*?)\r\n(.*)$} [dict get $wapp CONTENT] all divider body
|
||||
set ndiv [string length $divider]
|
||||
while {[string length $body]} {
|
||||
set idx [string first $divider $body]
|
||||
set unit [string range $body 0 [expr {$idx-3}]]
|
||||
set body [string range $body [expr {$idx+$ndiv+2}] end]
|
||||
if {[regexp {^Content-Disposition: form-data; (.*?)\r\n\r\n(.*)$} \
|
||||
$unit unit hdr content]} {
|
||||
if {[regexp {name="(.*)"; filename="(.*)"\r\nContent-Type: (.*?)$}\
|
||||
$hdr hr name filename mimetype]} {
|
||||
dict set wapp $name.filename \
|
||||
[string map [list \\\" \" \\\\ \\] $filename]
|
||||
dict set wapp $name.mimetype $mimetype
|
||||
dict set wapp $name.content $content
|
||||
} elseif {[regexp {name="(.*)"} $hdr hr name]} {
|
||||
dict set wapp $name $content
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Invoke application-supplied methods to generate a reply to
|
||||
# a single HTTP request.
|
||||
#
|
||||
# This routine always runs within [catch], so handle exceptions by
|
||||
# invoking [error].
|
||||
#
|
||||
proc wappInt-handle-request {chan useCgi} {
|
||||
global wapp
|
||||
dict set wapp .reply {}
|
||||
dict set wapp .mimetype {text/html; charset=utf-8}
|
||||
dict set wapp .reply-code {200 Ok}
|
||||
dict set wapp .csp {default-src 'self'}
|
||||
|
||||
# Set up additional CGI environment values
|
||||
#
|
||||
if {![dict exists $wapp HTTP_HOST]} {
|
||||
dict set wapp BASE_URL {}
|
||||
} elseif {[dict exists $wapp HTTPS]} {
|
||||
dict set wapp BASE_URL https://[dict get $wapp HTTP_HOST]
|
||||
} else {
|
||||
dict set wapp BASE_URL http://[dict get $wapp HTTP_HOST]
|
||||
}
|
||||
if {![dict exists $wapp REQUEST_URI]} {
|
||||
dict set wapp REQUEST_URI /
|
||||
} elseif {[regsub {\?.*} [dict get $wapp REQUEST_URI] {} newR]} {
|
||||
# Some servers (ex: nginx) append the query parameters to REQUEST_URI.
|
||||
# These need to be stripped off
|
||||
dict set wapp REQUEST_URI $newR
|
||||
}
|
||||
if {[dict exists $wapp SCRIPT_NAME]} {
|
||||
dict append wapp BASE_URL [dict get $wapp SCRIPT_NAME]
|
||||
} else {
|
||||
dict set wapp SCRIPT_NAME {}
|
||||
}
|
||||
if {![dict exists $wapp PATH_INFO]} {
|
||||
# If PATH_INFO is missing (ex: nginx) then construct it
|
||||
set URI [dict get $wapp REQUEST_URI]
|
||||
set skip [string length [dict get $wapp SCRIPT_NAME]]
|
||||
dict set wapp PATH_INFO [string range $URI $skip end]
|
||||
}
|
||||
if {[regexp {^/([^/]+)(.*)$} [dict get $wapp PATH_INFO] all head tail]} {
|
||||
dict set wapp PATH_HEAD $head
|
||||
dict set wapp PATH_TAIL [string trimleft $tail /]
|
||||
} else {
|
||||
dict set wapp PATH_INFO {}
|
||||
dict set wapp PATH_HEAD {}
|
||||
dict set wapp PATH_TAIL {}
|
||||
}
|
||||
dict set wapp SELF_URL [dict get $wapp BASE_URL]/[dict get $wapp PATH_HEAD]
|
||||
|
||||
# Parse query parameters from the query string, the cookies, and
|
||||
# POST data
|
||||
#
|
||||
if {[dict exists $wapp HTTP_COOKIE]} {
|
||||
foreach qterm [split [dict get $wapp HTTP_COOKIE] {;}] {
|
||||
set qsplit [split [string trim $qterm] =]
|
||||
set nm [lindex $qsplit 0]
|
||||
if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} {
|
||||
dict set wapp $nm [wappInt-decode-url [lindex $qsplit 1]]
|
||||
}
|
||||
}
|
||||
}
|
||||
set same_origin 0
|
||||
if {[dict exists $wapp HTTP_REFERER]} {
|
||||
set referer [dict get $wapp HTTP_REFERER]
|
||||
set base [dict get $wapp BASE_URL]
|
||||
if {$referer==$base || [string match $base/* $referer]} {
|
||||
set same_origin 1
|
||||
}
|
||||
}
|
||||
dict set wapp SAME_ORIGIN $same_origin
|
||||
if {$same_origin} {
|
||||
wappInt-decode-query-params
|
||||
}
|
||||
|
||||
# Invoke the application-defined handler procedure for this page
|
||||
# request. If an error occurs while running that procedure, generate
|
||||
# an HTTP reply that contains the error message.
|
||||
#
|
||||
wapp-before-dispatch-hook
|
||||
wappInt-trace
|
||||
set mname [dict get $wapp PATH_HEAD]
|
||||
if {[catch {
|
||||
if {$mname!="" && [llength [info proc wapp-page-$mname]]>0} {
|
||||
wapp-page-$mname
|
||||
} else {
|
||||
wapp-default
|
||||
}
|
||||
} msg]} {
|
||||
if {[wapp-param WAPP_MODE]=="local" || [wapp-param WAPP_MODE]=="server"} {
|
||||
puts "ERROR: $::errorInfo"
|
||||
}
|
||||
wapp-reset
|
||||
wapp-reply-code "500 Internal Server Error"
|
||||
wapp-mimetype text/html
|
||||
wapp-trim {
|
||||
<h1>Wapp Application Error</h1>
|
||||
<pre>%html($::errorInfo)</pre>
|
||||
}
|
||||
dict unset wapp .new-cookies
|
||||
}
|
||||
|
||||
# Transmit the HTTP reply
|
||||
#
|
||||
if {$chan=="stdout"} {
|
||||
puts $chan "Status: [dict get $wapp .reply-code]\r"
|
||||
} else {
|
||||
puts $chan "HTTP/1.1 [dict get $wapp .reply-code]\r"
|
||||
puts $chan "Server: wapp\r"
|
||||
puts $chan "Connection: close\r"
|
||||
}
|
||||
if {[dict exists $wapp .reply-extra]} {
|
||||
foreach {name value} [dict get $wapp .reply-extra] {
|
||||
puts $chan "$name: $value\r"
|
||||
}
|
||||
}
|
||||
if {[dict exists $wapp .csp]} {
|
||||
puts $chan "Content-Security-Policy: [dict get $wapp .csp]\r"
|
||||
}
|
||||
set mimetype [dict get $wapp .mimetype]
|
||||
puts $chan "Content-Type: $mimetype\r"
|
||||
if {[dict exists $wapp .new-cookies]} {
|
||||
foreach {nm val} [dict get $wapp .new-cookies] {
|
||||
if {[regexp {^[a-z][-a-z0-9_]*$} $nm]} {
|
||||
if {$val==""} {
|
||||
puts $chan "Set-Cookie: $nm=; HttpOnly; Path=/; Max-Age=1\r"
|
||||
} else {
|
||||
set val [wappInt-enc-url $val]
|
||||
puts $chan "Set-Cookie: $nm=$val; HttpOnly; Path=/\r"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if {[string match text/* $mimetype]} {
|
||||
set reply [encoding convertto utf-8 [dict get $wapp .reply]]
|
||||
if {[regexp {\ygzip\y} [wapp-param HTTP_ACCEPT_ENCODING]]} {
|
||||
catch {
|
||||
set x [zlib gzip $reply]
|
||||
set reply $x
|
||||
puts $chan "Content-Encoding: gzip\r"
|
||||
}
|
||||
}
|
||||
} else {
|
||||
set reply [dict get $wapp .reply]
|
||||
}
|
||||
puts $chan "Content-Length: [string length $reply]\r"
|
||||
puts $chan \r
|
||||
puts -nonewline $chan $reply
|
||||
flush $chan
|
||||
wappInt-close-channel $chan
|
||||
}
|
||||
|
||||
# This routine runs just prior to request-handler dispatch. The
|
||||
# default implementation is a no-op, but applications can override
|
||||
# to do additional transformations or checks.
|
||||
#
|
||||
proc wapp-before-dispatch-hook {} {return}
|
||||
|
||||
# Process a single CGI request
|
||||
#
|
||||
proc wappInt-handle-cgi-request {} {
|
||||
global wapp env
|
||||
foreach key {
|
||||
CONTENT_LENGTH
|
||||
CONTENT_TYPE
|
||||
DOCUMENT_ROOT
|
||||
HTTP_ACCEPT_ENCODING
|
||||
HTTP_COOKIE
|
||||
HTTP_HOST
|
||||
HTTP_REFERER
|
||||
HTTP_USER_AGENT
|
||||
HTTPS
|
||||
PATH_INFO
|
||||
QUERY_STRING
|
||||
REMOTE_ADDR
|
||||
REQUEST_METHOD
|
||||
REQUEST_URI
|
||||
REMOTE_USER
|
||||
SCRIPT_FILENAME
|
||||
SCRIPT_NAME
|
||||
SERVER_NAME
|
||||
SERVER_PORT
|
||||
SERVER_PROTOCOL
|
||||
} {
|
||||
if {[info exists env($key)]} {
|
||||
dict set wapp $key $env($key)
|
||||
}
|
||||
}
|
||||
set len 0
|
||||
if {[dict exists $wapp CONTENT_LENGTH]} {
|
||||
set len [dict get $wapp CONTENT_LENGTH]
|
||||
}
|
||||
if {$len>0} {
|
||||
fconfigure stdin -translation binary
|
||||
dict set wapp CONTENT [read stdin $len]
|
||||
}
|
||||
dict set wapp WAPP_MODE cgi
|
||||
fconfigure stdout -translation binary
|
||||
wappInt-handle-request stdout 1
|
||||
}
|
||||
|
||||
# Process new text received on an inbound SCGI request
|
||||
#
|
||||
proc wappInt-scgi-readable {chan} {
|
||||
if {[catch [list wappInt-scgi-readable-unsafe $chan] msg]} {
|
||||
puts stderr "$msg\n$::errorInfo"
|
||||
wappInt-close-channel $chan
|
||||
}
|
||||
}
|
||||
proc wappInt-scgi-readable-unsafe {chan} {
|
||||
upvar #0 wappInt-$chan W wapp wapp
|
||||
if {![dict exists $W .toread]} {
|
||||
# If the .toread key is not set, that means we are still reading
|
||||
# the header.
|
||||
#
|
||||
# An SGI header is short. This implementation assumes the entire
|
||||
# header is available all at once.
|
||||
#
|
||||
dict set W .remove_addr [dict get $W REMOTE_ADDR]
|
||||
set req [read $chan 15]
|
||||
set n [string length $req]
|
||||
scan $req %d:%s len hdr
|
||||
incr len [string length "$len:,"]
|
||||
append hdr [read $chan [expr {$len-15}]]
|
||||
foreach {nm val} [split $hdr \000] {
|
||||
if {$nm==","} break
|
||||
dict set W $nm $val
|
||||
}
|
||||
set len 0
|
||||
if {[dict exists $W CONTENT_LENGTH]} {
|
||||
set len [dict get $W CONTENT_LENGTH]
|
||||
}
|
||||
if {$len>0} {
|
||||
# Still need to read the query content
|
||||
dict set W .toread $len
|
||||
} else {
|
||||
# There is no query content, so handle the request immediately
|
||||
dict set W SERVER_ADDR [dict get $W .remove_addr]
|
||||
set wapp $W
|
||||
wappInt-handle-request $chan 0
|
||||
}
|
||||
} else {
|
||||
# If .toread is set, that means we are reading the query content.
|
||||
# Continue reading until .toread reaches zero.
|
||||
set got [read $chan [dict get $W .toread]]
|
||||
dict append W CONTENT $got
|
||||
dict set W .toread [expr {[dict get $W .toread]-[string length $got]}]
|
||||
if {[dict get $W .toread]<=0} {
|
||||
# Handle the request as soon as all the query content is received
|
||||
dict set W SERVER_ADDR [dict get $W .remove_addr]
|
||||
set wapp $W
|
||||
wappInt-handle-request $chan 0
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Start up the wapp framework. Parameters are a list passed as the
|
||||
# single argument.
|
||||
#
|
||||
# -server $PORT Listen for HTTP requests on this TCP port $PORT
|
||||
#
|
||||
# -local $PORT Listen for HTTP requests on 127.0.0.1:$PORT
|
||||
#
|
||||
# -scgi $PORT Listen for SCGI requests on 127.0.0.1:$PORT
|
||||
#
|
||||
# -remote-scgi $PORT Listen for SCGI requests on TCP port $PORT
|
||||
#
|
||||
# -cgi Handle a single CGI request
|
||||
#
|
||||
# With no arguments, the behavior is called "auto". In "auto" mode,
|
||||
# if the GATEWAY_INTERFACE environment variable indicates CGI, then run
|
||||
# as CGI. Otherwise, start an HTTP server bound to the loopback address
|
||||
# only, on an arbitrary TCP port, and automatically launch a web browser
|
||||
# on that TCP port.
|
||||
#
|
||||
# Additional options:
|
||||
#
|
||||
# -fromip GLOB Reject any incoming request where the remote
|
||||
# IP address does not match the GLOB pattern. This
|
||||
# value defaults to '127.0.0.1' for -local and -scgi.
|
||||
#
|
||||
# -nowait Do not wait in the event loop. Return immediately
|
||||
# after all event handlers are established.
|
||||
#
|
||||
# -trace "puts" each request URL as it is handled, for
|
||||
# debugging
|
||||
#
|
||||
# -lint Run wapp-safety-check on the application instead
|
||||
# of running the application itself
|
||||
#
|
||||
# -Dvar=value Set TCL global variable "var" to "value"
|
||||
#
|
||||
#
|
||||
proc wapp-start {arglist} {
|
||||
global env
|
||||
set mode auto
|
||||
set port 0
|
||||
set nowait 0
|
||||
set fromip {}
|
||||
set n [llength $arglist]
|
||||
for {set i 0} {$i<$n} {incr i} {
|
||||
set term [lindex $arglist $i]
|
||||
if {[string match --* $term]} {set term [string range $term 1 end]}
|
||||
switch -glob -- $term {
|
||||
-server {
|
||||
incr i;
|
||||
set mode "server"
|
||||
set port [lindex $arglist $i]
|
||||
}
|
||||
-local {
|
||||
incr i;
|
||||
set mode "local"
|
||||
set fromip 127.0.0.1
|
||||
set port [lindex $arglist $i]
|
||||
}
|
||||
-scgi {
|
||||
incr i;
|
||||
set mode "scgi"
|
||||
set fromip 127.0.0.1
|
||||
set port [lindex $arglist $i]
|
||||
}
|
||||
-remote-scgi {
|
||||
incr i;
|
||||
set mode "remote-scgi"
|
||||
set port [lindex $arglist $i]
|
||||
}
|
||||
-cgi {
|
||||
set mode "cgi"
|
||||
}
|
||||
-fromip {
|
||||
incr i
|
||||
set fromip [lindex $arglist $i]
|
||||
}
|
||||
-nowait {
|
||||
set nowait 1
|
||||
}
|
||||
-trace {
|
||||
proc wappInt-trace {} {
|
||||
set q [wapp-param QUERY_STRING]
|
||||
set uri [wapp-param BASE_URL][wapp-param PATH_INFO]
|
||||
if {$q!=""} {append uri ?$q}
|
||||
puts $uri
|
||||
}
|
||||
}
|
||||
-lint {
|
||||
set res [wapp-safety-check]
|
||||
if {$res!=""} {
|
||||
puts "Potential problems in this code:"
|
||||
puts $res
|
||||
exit 1
|
||||
} else {
|
||||
exit
|
||||
}
|
||||
}
|
||||
-D*=* {
|
||||
if {[regexp {^.D([^=]+)=(.*)$} $term all var val]} {
|
||||
set ::$var $val
|
||||
}
|
||||
}
|
||||
default {
|
||||
error "unknown option: $term"
|
||||
}
|
||||
}
|
||||
}
|
||||
if {$mode=="auto"} {
|
||||
if {[info exists env(GATEWAY_INTERFACE)]
|
||||
&& [string match CGI/1.* $env(GATEWAY_INTERFACE)]} {
|
||||
set mode cgi
|
||||
} else {
|
||||
set mode local
|
||||
}
|
||||
}
|
||||
if {$mode=="cgi"} {
|
||||
wappInt-handle-cgi-request
|
||||
} else {
|
||||
wappInt-start-listener $port $mode $fromip
|
||||
if {!$nowait} {
|
||||
vwait ::forever
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Call this version 1.0
|
||||
package provide wapp 1.0
|
||||
506
test/wapptest.tcl
Executable file
506
test/wapptest.tcl
Executable file
@ -0,0 +1,506 @@
|
||||
#!/bin/sh
|
||||
# \
|
||||
exec wapptclsh "$0" ${1+"$@"}
|
||||
|
||||
#
|
||||
#
|
||||
#
|
||||
|
||||
# Variables set by the "control" form:
|
||||
#
|
||||
# G(platform) - User selected platform.
|
||||
# G(test) - Set to "Normal", "Veryquick", "Smoketest" or "Build-Only".
|
||||
# G(keep) - Boolean. True to delete no files after each test.
|
||||
# G(msvc) - Boolean. True to use MSVC as the compiler.
|
||||
# G(tcl) - Use Tcl from this directory for builds.
|
||||
# G(jobs) - How many sub-processes to run simultaneously.
|
||||
#
|
||||
set G(platform) $::tcl_platform(os)-$::tcl_platform(machine)
|
||||
set G(test) Normal
|
||||
set G(keep) 0
|
||||
set G(msvc) 0
|
||||
set G(tcl) ""
|
||||
set G(jobs) 3
|
||||
|
||||
set G(sqlite_version) unknown
|
||||
|
||||
# The root of the SQLite source tree.
|
||||
#
|
||||
set G(srcdir) [file dirname [file dirname [info script]]]
|
||||
|
||||
# Either "config", "running", "stopped":
|
||||
#
|
||||
set G(state) "config"
|
||||
|
||||
# releasetest.tcl script
|
||||
#
|
||||
set G(releaseTest) [file join [file dirname [info script]] releasetest.tcl]
|
||||
|
||||
set G(cnt) 0
|
||||
|
||||
# package required wapp
|
||||
source [file join [file dirname [info script]] wapp.tcl]
|
||||
|
||||
# Read the data from the releasetest_data.tcl script.
|
||||
#
|
||||
source [file join [file dirname [info script]] releasetest_data.tcl]
|
||||
|
||||
# Check to see if there are uncommitted changes in the SQLite source
|
||||
# directory. Return true if there are, or false otherwise.
|
||||
#
|
||||
proc check_uncommitted {} {
|
||||
global G
|
||||
set ret 0
|
||||
set pwd [pwd]
|
||||
cd $G(srcdir)
|
||||
if {[catch {exec fossil changes} res]==0 && [string trim $res]!=""} {
|
||||
set ret 1
|
||||
}
|
||||
cd $pwd
|
||||
return $ret
|
||||
}
|
||||
|
||||
# If the application is in "config" state, set the contents of the
|
||||
# ::G(test_array) global to reflect the tests that will be run. If the
|
||||
# app is in some other state ("running" or "stopped"), this command
|
||||
# is a no-op.
|
||||
#
|
||||
proc set_test_array {} {
|
||||
global G
|
||||
if { $G(state)=="config" } {
|
||||
set G(test_array) [list]
|
||||
foreach {config target} $::Platforms($G(platform)) {
|
||||
|
||||
# If using MSVC, do not run sanitize or valgrind tests. Or the
|
||||
# checksymbols test.
|
||||
if {$G(msvc) && (
|
||||
"Sanitize" == $config
|
||||
|| "checksymbols" in $target
|
||||
|| "valgrindtest" in $target
|
||||
)} {
|
||||
continue
|
||||
}
|
||||
|
||||
# If the test mode is not "Normal", override the target.
|
||||
#
|
||||
if {$target!="checksymbols" && $G(platform)!="Failure-Detection"} {
|
||||
switch -- $G(test) {
|
||||
Veryquick { set target quicktest }
|
||||
Smoketest { set target smoketest }
|
||||
Build-Only {
|
||||
set target testfixture
|
||||
if {$::tcl_platform(platform)=="windows"} {
|
||||
set target testfixture.exe
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
lappend G(test_array) [dict create config $config target $target]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc count_tests_and_errors {name logfile} {
|
||||
global G
|
||||
|
||||
set fd [open $logfile rb]
|
||||
set seen 0
|
||||
while {![eof $fd]} {
|
||||
set line [gets $fd]
|
||||
if {[regexp {(\d+) errors out of (\d+) tests} $line all nerr ntest]} {
|
||||
incr G(test.$name.nError) $nerr
|
||||
incr G(test.$name.nTest) $ntest
|
||||
set seen 1
|
||||
if {$nerr>0} {
|
||||
set G(test.$name.errmsg) $line
|
||||
}
|
||||
}
|
||||
if {[regexp {runtime error: +(.*)} $line all msg]} {
|
||||
# skip over "value is outside range" errors
|
||||
if {[regexp {value .* is outside the range of representable} $line]} {
|
||||
# noop
|
||||
} else {
|
||||
incr G(test.$name.nError)
|
||||
if {$G(test.$name.errmsg)==""} {
|
||||
set G(test.$name.errmsg) $msg
|
||||
}
|
||||
}
|
||||
}
|
||||
if {[regexp {fatal error +(.*)} $line all msg]} {
|
||||
incr G(test.$name.nError)
|
||||
if {$G(test.$name.errmsg)==""} {
|
||||
set G(test.$name.errmsg) $msg
|
||||
}
|
||||
}
|
||||
if {[regexp {ERROR SUMMARY: (\d+) errors.*} $line all cnt] && $cnt>0} {
|
||||
incr G(test.$name.nError)
|
||||
if {$G(test.$name.errmsg)==""} {
|
||||
set G(test.$name.errmsg) $all
|
||||
}
|
||||
}
|
||||
if {[regexp {^VERSION: 3\.\d+.\d+} $line]} {
|
||||
set v [string range $line 9 end]
|
||||
if {$G(sqlite_version) eq "unknown"} {
|
||||
set G(sqlite_version) $v
|
||||
} elseif {$G(sqlite_version) ne $v} {
|
||||
set G(test.$name.errmsg) "version conflict: {$G(sqlite_version)} vs. {$v}"
|
||||
}
|
||||
}
|
||||
}
|
||||
close $fd
|
||||
if {$G(test) == "Build-Only"} {
|
||||
incr G(test.$name.nTest)
|
||||
if {$G(test.$name.nError)>0} {
|
||||
set errmsg "Build failed"
|
||||
}
|
||||
} elseif {!$seen} {
|
||||
set G(test.$name.errmsg) "Test did not complete"
|
||||
if {[file readable core]} {
|
||||
append G(test.$name.errmsg) " - core file exists"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc slave_fileevent {name} {
|
||||
global G
|
||||
set fd $G(test.$name.channel)
|
||||
|
||||
if {[eof $fd]} {
|
||||
fconfigure $fd -blocking 1
|
||||
set rc [catch { close $fd }]
|
||||
unset G(test.$name.channel)
|
||||
set G(test.$name.done) [clock seconds]
|
||||
set G(test.$name.nError) 0
|
||||
set G(test.$name.nTest) 0
|
||||
set G(test.$name.errmsg) ""
|
||||
if {$rc} {
|
||||
incr G(test.$name.nError)
|
||||
}
|
||||
if {[file exists $G(test.$name.log)]} {
|
||||
count_tests_and_errors $name $G(test.$name.log)
|
||||
}
|
||||
} else {
|
||||
set line [gets $fd]
|
||||
if {[string trim $line] != ""} { puts "Trace : $name - \"$line\"" }
|
||||
}
|
||||
|
||||
do_some_stuff
|
||||
}
|
||||
|
||||
proc do_some_stuff {} {
|
||||
global G
|
||||
|
||||
# Count the number of running jobs. A running job has an entry named
|
||||
# "channel" in its dictionary.
|
||||
set nRunning 0
|
||||
set bFinished 1
|
||||
foreach j $G(test_array) {
|
||||
set name [dict get $j config]
|
||||
if { [info exists G(test.$name.channel)]} { incr nRunning }
|
||||
if {![info exists G(test.$name.done)]} { set bFinished 0 }
|
||||
}
|
||||
|
||||
if {$bFinished} {
|
||||
set nError 0
|
||||
set nTest 0
|
||||
set nConfig 0
|
||||
foreach j $G(test_array) {
|
||||
set name [dict get $j config]
|
||||
incr nError $G(test.$name.nError)
|
||||
incr nTest $G(test.$name.nTest)
|
||||
incr nConfig
|
||||
}
|
||||
set G(result) "$nError errors from $nTest tests in $nConfig configurations."
|
||||
catch {
|
||||
append G(result) " SQLite version $G(sqlite_version)"
|
||||
}
|
||||
} else {
|
||||
set nLaunch [expr $G(jobs) - $nRunning]
|
||||
foreach j $G(test_array) {
|
||||
if {$nLaunch<=0} break
|
||||
set name [dict get $j config]
|
||||
if { ![info exists G(test.$name.channel)]
|
||||
&& ![info exists G(test.$name.done)]
|
||||
} {
|
||||
set target [dict get $j target]
|
||||
set G(test.$name.start) [clock seconds]
|
||||
set fd [open "|[info nameofexecutable] $G(releaseTest) --slave" r+]
|
||||
set G(test.$name.channel) $fd
|
||||
fconfigure $fd -blocking 0
|
||||
fileevent $fd readable [list slave_fileevent $name]
|
||||
|
||||
puts $fd [list 0 $G(msvc) 0 $G(keep)]
|
||||
set L [make_test_suite $G(msvc) "" $name $target $::Configs($name)]
|
||||
puts $fd $L
|
||||
flush $fd
|
||||
set G(test.$name.log) [file join [lindex $L 1] test.log]
|
||||
incr nLaunch -1
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc generate_main_page {{extra {}}} {
|
||||
global G
|
||||
set_test_array
|
||||
|
||||
wapp-trim {
|
||||
<html>
|
||||
<head>
|
||||
<link rel="stylesheet" type="text/css" href="style.css"/>
|
||||
</head>
|
||||
<body>
|
||||
}
|
||||
|
||||
# If the checkout contains uncommitted changs, put a warning at the top
|
||||
# of the page.
|
||||
if {[check_uncommitted]} {
|
||||
wapp-trim {
|
||||
<div class=warning>
|
||||
WARNING: Uncommitted changes in checkout.
|
||||
</div>
|
||||
}
|
||||
}
|
||||
|
||||
wapp-trim {
|
||||
<div class=div id=controls>
|
||||
<form action="control" method="post" name="control">
|
||||
<label> Platform: </label>
|
||||
<select id="control_platform" name="control_platform">
|
||||
}
|
||||
foreach platform [array names ::Platforms] {
|
||||
set selected ""
|
||||
if {$platform==$G(platform)} { set selected " selected=1" }
|
||||
wapp-subst "<option $selected>$platform</option>"
|
||||
}
|
||||
wapp-trim {
|
||||
</select>
|
||||
<label> Test: </label>
|
||||
<select id="control_test" name="control_test">
|
||||
}
|
||||
foreach test [list Normal Veryquick Smoketest Build-Only] {
|
||||
set selected ""
|
||||
if {$test==$G(test)} { set selected " selected=1" }
|
||||
wapp-subst "<option $selected>$test</option>"
|
||||
}
|
||||
wapp-trim [subst -nocommands {
|
||||
</select>
|
||||
<label> Tcl: </label>
|
||||
<input id="control_tcl" name="control_tcl"></input>
|
||||
|
||||
<label> Keep files: </label>
|
||||
<input id="control_keep" name="control_keep" type=checkbox value=1>
|
||||
</input>
|
||||
<label> Use MSVC: </label>
|
||||
<input id="control_msvc" name="control_msvc" type=checkbox value=1>
|
||||
</input>
|
||||
<hr>
|
||||
<div class=right>
|
||||
<label> Jobs: </label>
|
||||
<select id="control_jobs" name="control_jobs">
|
||||
}]
|
||||
for {set i 1} {$i <= 8} {incr i} {
|
||||
if {$G(jobs)==$i} {
|
||||
wapp-trim {
|
||||
<option selected=1>%string($i)</option>
|
||||
}
|
||||
} else {
|
||||
wapp-trim {
|
||||
<option>%string($i)</option>
|
||||
}
|
||||
}
|
||||
}
|
||||
wapp-trim {
|
||||
</select>
|
||||
<input id=control_go name=control_go type=submit value="Run Tests!">
|
||||
</input>
|
||||
</div>
|
||||
</form>
|
||||
</div>
|
||||
<div class=div id=tests>
|
||||
<table>
|
||||
}
|
||||
foreach t $G(test_array) {
|
||||
set config [dict get $t config]
|
||||
set target [dict get $t target]
|
||||
|
||||
set class "testwait"
|
||||
set seconds ""
|
||||
|
||||
if {[info exists G(test.$config.log)]} {
|
||||
if {[info exists G(test.$config.channel)]} {
|
||||
set class "testrunning"
|
||||
set seconds [expr [clock seconds] - $G(test.$config.start)]
|
||||
} elseif {[info exists G(test.$config.done)]} {
|
||||
if {$G(test.$config.nError)>0} {
|
||||
set class "testfail"
|
||||
} else {
|
||||
set class "testdone"
|
||||
}
|
||||
set seconds [expr $G(test.$config.done) - $G(test.$config.start)]
|
||||
}
|
||||
|
||||
set min [format %.2d [expr ($seconds / 60) % 60]]
|
||||
set hr [format %.2d [expr $seconds / 3600]]
|
||||
set sec [format %.2d [expr $seconds % 60]]
|
||||
set seconds "$hr:$min:$sec"
|
||||
}
|
||||
|
||||
wapp-trim {
|
||||
<tr class=%string($class)>
|
||||
<td class=testfield> %html($config)
|
||||
<td class=testfield> %html($target)
|
||||
<td class=testfield> %html($seconds)
|
||||
<td class=testfield>
|
||||
}
|
||||
if {[info exists G(test.$config.log)]} {
|
||||
set log $G(test.$config.log)
|
||||
set uri "log/$log"
|
||||
wapp-trim {
|
||||
<a href=%url($uri)> %html($log) </a>
|
||||
}
|
||||
}
|
||||
if {[info exists G(test.$config.errmsg)] && $G(test.$config.errmsg)!=""} {
|
||||
set errmsg $G(test.$config.errmsg)
|
||||
wapp-trim {
|
||||
<tr class=testfail>
|
||||
<td class=testfield>
|
||||
<td class=testfield colspan=3> %html($errmsg)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
wapp-trim {
|
||||
</table>
|
||||
</div>
|
||||
}
|
||||
if {[info exists G(result)]} {
|
||||
set res $G(result)
|
||||
wapp-trim {
|
||||
<div class=div id=log> %string($res) </div>
|
||||
}
|
||||
}
|
||||
wapp-trim {
|
||||
<script src="script.js"></script>
|
||||
</body>
|
||||
</html>
|
||||
}
|
||||
incr G(cnt)
|
||||
}
|
||||
|
||||
proc wapp-default {} {
|
||||
generate_main_page
|
||||
}
|
||||
|
||||
proc wapp-page-control {} {
|
||||
global G
|
||||
foreach v {platform test tcl jobs keep msvc} {
|
||||
if {[wapp-param-exists control_$v]} {
|
||||
set G($v) [wapp-param control_$v]
|
||||
} else {
|
||||
set G($v) 0
|
||||
}
|
||||
}
|
||||
|
||||
if {[wapp-param-exists control_go]} {
|
||||
# This is an actual "run test" command, not just a change of
|
||||
# configuration!
|
||||
set_test_array
|
||||
set ::G(state) "running"
|
||||
}
|
||||
|
||||
if {$::G(state) == "running"} {
|
||||
do_some_stuff
|
||||
}
|
||||
|
||||
wapp-redirect /
|
||||
}
|
||||
|
||||
proc wapp-page-style.css {} {
|
||||
wapp-subst {
|
||||
.div {
|
||||
border: 3px groove #444444;
|
||||
margin: 1em;
|
||||
padding: 1em;
|
||||
}
|
||||
|
||||
.warning {
|
||||
text-align:center;
|
||||
color: red;
|
||||
font-size: 2em;
|
||||
font-weight: bold;
|
||||
}
|
||||
|
||||
.right {
|
||||
}
|
||||
|
||||
.testfield {
|
||||
padding-right: 10ex;
|
||||
}
|
||||
|
||||
.testwait {}
|
||||
.testrunning { color: blue }
|
||||
.testdone { color: green }
|
||||
.testfail { color: red }
|
||||
}
|
||||
}
|
||||
|
||||
proc wapp-page-script.js {} {
|
||||
|
||||
set tcl $::G(tcl)
|
||||
set keep $::G(keep)
|
||||
set msvc $::G(msvc)
|
||||
|
||||
wapp-subst {
|
||||
var lElem = \["control_platform", "control_test", "control_msvc", "control_jobs"\];
|
||||
lElem.forEach(function(e) {
|
||||
var elem = document.getElementById(e);
|
||||
elem.addEventListener("change", function() { control.submit() } );
|
||||
})
|
||||
|
||||
elem = document.getElementById("control_tcl");
|
||||
elem.value = "%string($tcl)"
|
||||
|
||||
elem = document.getElementById("control_keep");
|
||||
elem.checked = %string($keep);
|
||||
|
||||
elem = document.getElementById("control_msvc");
|
||||
elem.checked = %string($msvc);
|
||||
}
|
||||
|
||||
if {$::G(state)!="config"} {
|
||||
wapp-subst {
|
||||
var lElem = \["control_platform", "control_test",
|
||||
"control_tcl", "control_keep", "control_msvc", "control_go"
|
||||
\];
|
||||
lElem.forEach(function(e) {
|
||||
var elem = document.getElementById(e);
|
||||
elem.disabled = true;
|
||||
})
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc wapp-page-env {} {
|
||||
wapp-allow-xorigin-params
|
||||
wapp-trim {
|
||||
<h1>Wapp Environment</h1>\n<pre>
|
||||
<pre>%html([wapp-debug-env])</pre>
|
||||
}
|
||||
}
|
||||
|
||||
proc wapp-page-log {} {
|
||||
set log [string range [wapp-param REQUEST_URI] 5 end]
|
||||
set fd [open $log]
|
||||
set data [read $fd]
|
||||
close $fd
|
||||
wapp-trim {
|
||||
<pre>
|
||||
%html($data)
|
||||
</pre>
|
||||
}
|
||||
}
|
||||
|
||||
wapp-start $argv
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user