/ Check-in [a4af0c2f]
Login

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

Overview
Comment:Add test/wapptest.tcl, a wapp alternative to releasetest.tcl.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | wapptest
Files: files | file ages | folders
SHA3-256: a4af0c2fee05aaa2e95ae6a5c847ff2d363e24f325f4ffdcf51bc264b9bf5e2d
User & Date: dan 2019-04-09 19:53:32
Context
2019-04-10
18:56
Various fixes for the wapptest.tcl script. check-in: cbf42365 user: dan tags: wapptest
2019-04-09
19:53
Add test/wapptest.tcl, a wapp alternative to releasetest.tcl. check-in: a4af0c2f user: dan tags: wapptest
2019-04-07
18:21
Make the testcase() macro added in the previous check-in reachable for testing. check-in: 80704a16 user: drh tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

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 {& &amp; < &lt; > &gt; \" &quot; \\ &#92;} $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  +#
            6  +#
            7  +#
            8  +
            9  +# Variables set by the "control" form:
           10  +#
           11  +#   G(platform) - User selected platform.
           12  +#   G(test)     - Set to "Normal", "Veryquick", "Smoketest" or "Build-Only".
           13  +#   G(keep)     - Boolean. True to delete no files after each test.
           14  +#   G(msvc)     - Boolean. True to use MSVC as the compiler.
           15  +#   G(tcl)      - Use Tcl from this directory for builds.
           16  +#   G(jobs)     - How many sub-processes to run simultaneously.
           17  +#
           18  +set G(platform) $::tcl_platform(os)-$::tcl_platform(machine)
           19  +set G(test)     Normal
           20  +set G(keep)     0
           21  +set G(msvc)     0
           22  +set G(tcl)      ""
           23  +set G(jobs)     3
           24  +
           25  +set G(sqlite_version) unknown
           26  +
           27  +# The root of the SQLite source tree.
           28  +#
           29  +set G(srcdir)   [file dirname [file dirname [info script]]]
           30  +
           31  +# Either "config", "running", "stopped":
           32  +#
           33  +set G(state) "config"
           34  +
           35  +# releasetest.tcl script
           36  +#
           37  +set G(releaseTest) [file join [file dirname [info script]] releasetest.tcl]
           38  +
           39  +set G(cnt) 0
           40  +
           41  +# package required wapp
           42  +source [file join [file dirname [info script]] wapp.tcl]
           43  +
           44  +# Read the data from the releasetest_data.tcl script.
           45  +#
           46  +source [file join [file dirname [info script]] releasetest_data.tcl]
           47  +
           48  +# Check to see if there are uncommitted changes in the SQLite source
           49  +# directory. Return true if there are, or false otherwise.
           50  +#
           51  +proc check_uncommitted {} {
           52  +  global G
           53  +  set ret 0
           54  +  set pwd [pwd]
           55  +  cd $G(srcdir)
           56  +  if {[catch {exec fossil changes} res]==0 && [string trim $res]!=""} {
           57  +    set ret 1
           58  +  }
           59  +  cd $pwd
           60  +  return $ret
           61  +}
           62  +
           63  +# If the application is in "config" state, set the contents of the 
           64  +# ::G(test_array) global to reflect the tests that will be run. If the
           65  +# app is in some other state ("running" or "stopped"), this command
           66  +# is a no-op.
           67  +#
           68  +proc set_test_array {} {
           69  +  global G
           70  +  if { $G(state)=="config" } {
           71  +    set G(test_array) [list]
           72  +    foreach {config target} $::Platforms($G(platform)) {
           73  +
           74  +      # If using MSVC, do not run sanitize or valgrind tests. Or the
           75  +      # checksymbols test.
           76  +      if {$G(msvc) && (
           77  +          "Sanitize" == $config 
           78  +       || "checksymbols" in $target
           79  +       || "valgrindtest" in $target
           80  +      )} {
           81  +        continue
           82  +      }
           83  +
           84  +      # If the test mode is not "Normal", override the target.
           85  +      #
           86  +      if {$target!="checksymbols" && $G(platform)!="Failure-Detection"} {
           87  +        switch -- $G(test) {
           88  +          Veryquick { set target quicktest }
           89  +          Smoketest { set target smoketest }
           90  +          Build-Only {
           91  +            set target testfixture
           92  +            if {$::tcl_platform(platform)=="windows"} {
           93  +              set target testfixture.exe
           94  +            }
           95  +          }
           96  +        }
           97  +      }
           98  +
           99  +      lappend G(test_array) [dict create config $config target $target]
          100  +    }
          101  +  }
          102  +}
          103  +
          104  +proc count_tests_and_errors {name logfile} {
          105  +  global G
          106  +
          107  +  set fd [open $logfile rb]
          108  +  set seen 0
          109  +  while {![eof $fd]} {
          110  +    set line [gets $fd]
          111  +    if {[regexp {(\d+) errors out of (\d+) tests} $line all nerr ntest]} {
          112  +      incr G(test.$name.nError) $nerr
          113  +      incr G(test.$name.nTest) $ntest
          114  +      set seen 1
          115  +      if {$nerr>0} {
          116  +        set G(test.$name.errmsg) $line
          117  +      }
          118  +    }
          119  +    if {[regexp {runtime error: +(.*)} $line all msg]} {
          120  +      # skip over "value is outside range" errors
          121  +      if {[regexp {value .* is outside the range of representable} $line]} {
          122  +         # noop
          123  +      } else {
          124  +        incr G(test.$name.nError)
          125  +        if {$G(test.$name.errmsg)==""} {
          126  +          set G(test.$name.errmsg) $msg
          127  +        }
          128  +      }
          129  +    }
          130  +    if {[regexp {fatal error +(.*)} $line all msg]} {
          131  +      incr G(test.$name.nError)
          132  +      if {$G(test.$name.errmsg)==""} {
          133  +        set G(test.$name.errmsg) $msg
          134  +      }
          135  +    }
          136  +    if {[regexp {ERROR SUMMARY: (\d+) errors.*} $line all cnt] && $cnt>0} {
          137  +      incr G(test.$name.nError)
          138  +      if {$G(test.$name.errmsg)==""} {
          139  +        set G(test.$name.errmsg) $all
          140  +      }
          141  +    }
          142  +    if {[regexp {^VERSION: 3\.\d+.\d+} $line]} {
          143  +      set v [string range $line 9 end]
          144  +      if {$G(sqlite_version) eq "unknown"} {
          145  +        set G(sqlite_version) $v
          146  +      } elseif {$G(sqlite_version) ne $v} {
          147  +        set G(test.$name.errmsg) "version conflict: {$G(sqlite_version)} vs. {$v}"
          148  +      }
          149  +    }
          150  +  }
          151  +  close $fd
          152  +  if {$G(test) == "Build-Only"} {
          153  +    incr G(test.$name.nTest)
          154  +    if {$G(test.$name.nError)>0} {
          155  +      set errmsg "Build failed"
          156  +    }
          157  +  } elseif {!$seen} {
          158  +    set G(test.$name.errmsg) "Test did not complete"
          159  +    if {[file readable core]} {
          160  +      append G(test.$name.errmsg) " - core file exists"
          161  +    }
          162  +  }
          163  +}
          164  +
          165  +proc slave_fileevent {name} {
          166  +  global G
          167  +  set fd $G(test.$name.channel)
          168  +
          169  +  if {[eof $fd]} {
          170  +    fconfigure $fd -blocking 1
          171  +    set rc [catch { close $fd }]
          172  +    unset G(test.$name.channel)
          173  +    set G(test.$name.done) [clock seconds]
          174  +    set G(test.$name.nError) 0
          175  +    set G(test.$name.nTest) 0
          176  +    set G(test.$name.errmsg) ""
          177  +    if {$rc} {
          178  +      incr G(test.$name.nError)
          179  +    }
          180  +    if {[file exists $G(test.$name.log)]} {
          181  +      count_tests_and_errors $name $G(test.$name.log)
          182  +    }
          183  +  } else {
          184  +    set line [gets $fd]
          185  +    if {[string trim $line] != ""} { puts "Trace   : $name - \"$line\"" }
          186  +  }
          187  +
          188  +  do_some_stuff
          189  +}
          190  +
          191  +proc do_some_stuff {} {
          192  +  global G
          193  +
          194  +  # Count the number of running jobs. A running job has an entry named
          195  +  # "channel" in its dictionary.
          196  +  set nRunning 0
          197  +  set bFinished 1
          198  +  foreach j $G(test_array) {
          199  +    set name [dict get $j config]
          200  +    if { [info exists G(test.$name.channel)]} { incr nRunning   }
          201  +    if {![info exists G(test.$name.done)]}    { set bFinished 0 }
          202  +  }
          203  +
          204  +  if {$bFinished} {
          205  +    set nError 0
          206  +    set nTest 0
          207  +    set nConfig 0
          208  +    foreach j $G(test_array) {
          209  +      set name [dict get $j config]
          210  +      incr nError $G(test.$name.nError)
          211  +      incr nTest $G(test.$name.nTest)
          212  +      incr nConfig 
          213  +    }
          214  +    set G(result) "$nError errors from $nTest tests in $nConfig configurations."
          215  +    catch {
          216  +      append G(result) " SQLite version $G(sqlite_version)"
          217  +    }
          218  +  } else {
          219  +    set nLaunch [expr $G(jobs) - $nRunning]
          220  +    foreach j $G(test_array) {
          221  +      if {$nLaunch<=0} break
          222  +      set name [dict get $j config]
          223  +      if { ![info exists G(test.$name.channel)]
          224  +        && ![info exists G(test.$name.done)]
          225  +      } {
          226  +        set target [dict get $j target]
          227  +        set G(test.$name.start) [clock seconds]
          228  +        set fd [open "|[info nameofexecutable] $G(releaseTest) --slave" r+]
          229  +        set G(test.$name.channel) $fd
          230  +        fconfigure $fd -blocking 0
          231  +        fileevent $fd readable [list slave_fileevent $name]
          232  +
          233  +        puts $fd [list 0 $G(msvc) 0 $G(keep)]
          234  +        set L [make_test_suite $G(msvc) "" $name $target $::Configs($name)]
          235  +        puts $fd $L
          236  +        flush $fd
          237  +        set G(test.$name.log) [file join [lindex $L 1] test.log]
          238  +        incr nLaunch -1
          239  +      }
          240  +    }
          241  +  }
          242  +}
          243  +
          244  +proc generate_main_page {{extra {}}} {
          245  +  global G
          246  +  set_test_array
          247  +
          248  +  wapp-trim {
          249  +    <html>
          250  +    <head>
          251  +      <link rel="stylesheet" type="text/css" href="style.css"/>
          252  +    </head>
          253  +    <body>
          254  +  }
          255  +
          256  +  # If the checkout contains uncommitted changs, put a warning at the top
          257  +  # of the page.
          258  +  if {[check_uncommitted]} {
          259  +    wapp-trim {
          260  +      <div class=warning>
          261  +        WARNING: Uncommitted changes in checkout.
          262  +      </div>
          263  +    }
          264  +  }
          265  +
          266  +  wapp-trim {
          267  +      <div class=div id=controls> 
          268  +        <form action="control" method="post" name="control">
          269  +        <label> Platform: </label>
          270  +        <select id="control_platform" name="control_platform">
          271  +  }
          272  +  foreach platform [array names ::Platforms] {
          273  +    set selected ""
          274  +    if {$platform==$G(platform)} { set selected " selected=1" }
          275  +    wapp-subst "<option $selected>$platform</option>"
          276  +  }
          277  +  wapp-trim {
          278  +        </select>
          279  +        <label> Test: </label>
          280  +        <select id="control_test" name="control_test">
          281  +  }
          282  +  foreach test [list Normal Veryquick Smoketest Build-Only] {
          283  +    set selected ""
          284  +    if {$test==$G(test)} { set selected " selected=1" }
          285  +    wapp-subst "<option $selected>$test</option>"
          286  +  }
          287  +  wapp-trim [subst -nocommands {
          288  +        </select>
          289  +        <label> Tcl: </label>
          290  +        <input id="control_tcl" name="control_tcl"></input>
          291  +
          292  +        <label> Keep files: </label>
          293  +        <input id="control_keep" name="control_keep" type=checkbox value=1>
          294  +        </input>
          295  +        <label> Use MSVC: </label>
          296  +        <input id="control_msvc" name="control_msvc" type=checkbox value=1>
          297  +        </input>
          298  +        <hr>
          299  +        <div class=right>
          300  +          <label> Jobs: </label>
          301  +          <select id="control_jobs" name="control_jobs">
          302  +  }]
          303  +  for {set i 1} {$i <= 8} {incr i} {
          304  +    if {$G(jobs)==$i} {
          305  +      wapp-trim {
          306  +        <option selected=1>%string($i)</option>
          307  +      }
          308  +    } else {
          309  +      wapp-trim {
          310  +        <option>%string($i)</option>
          311  +      }
          312  +    }
          313  +  }
          314  +  wapp-trim {
          315  +          </select>
          316  +          <input id=control_go name=control_go type=submit value="Run Tests!">
          317  +          </input>
          318  +        </div>
          319  +     </form>
          320  +      </div>
          321  +      <div class=div id=tests>    
          322  +      <table>
          323  +  }
          324  +  foreach t $G(test_array) {
          325  +    set config [dict get $t config]
          326  +    set target [dict get $t target]
          327  +
          328  +    set class "testwait"
          329  +    set seconds ""
          330  +
          331  +    if {[info exists G(test.$config.log)]} {
          332  +      if {[info exists G(test.$config.channel)]} {
          333  +        set class "testrunning"
          334  +        set seconds [expr [clock seconds] - $G(test.$config.start)]
          335  +      } elseif {[info exists G(test.$config.done)]} {
          336  +        if {$G(test.$config.nError)>0} {
          337  +          set class "testfail" 
          338  +        } else {
          339  +          set class "testdone"
          340  +        }
          341  +        set seconds [expr $G(test.$config.done) - $G(test.$config.start)]
          342  +      }
          343  +
          344  +      set min [format %.2d [expr ($seconds / 60) % 60]]
          345  +      set  hr [format %.2d [expr $seconds / 3600]]
          346  +      set sec [format %.2d [expr $seconds % 60]]
          347  +      set seconds "$hr:$min:$sec"
          348  +    }
          349  +
          350  +    wapp-trim {
          351  +      <tr class=%string($class)>
          352  +      <td class=testfield> %html($config) 
          353  +      <td class=testfield> %html($target)
          354  +      <td class=testfield> %html($seconds)
          355  +      <td class=testfield>
          356  +    }
          357  +    if {[info exists G(test.$config.log)]} {
          358  +      set log $G(test.$config.log)
          359  +      set uri "log/$log"
          360  +      wapp-trim {
          361  +        <a href=%url($uri)> %html($log) </a>
          362  +      }
          363  +    }
          364  +    if {[info exists G(test.$config.errmsg)] && $G(test.$config.errmsg)!=""} {
          365  +      set errmsg $G(test.$config.errmsg)
          366  +      wapp-trim {
          367  +        <tr class=testfail>
          368  +        <td class=testfield>
          369  +        <td class=testfield colspan=3> %html($errmsg)
          370  +      }
          371  +    }
          372  +  }
          373  +
          374  +  wapp-trim {
          375  +      </table>
          376  +      </div>
          377  +  }
          378  +  if {[info exists G(result)]} {
          379  +    set res $G(result)
          380  +    wapp-trim {
          381  +      <div class=div id=log> %string($res) </div>
          382  +    }
          383  +  }
          384  +  wapp-trim {
          385  +    <script src="script.js"></script>
          386  +    </body>
          387  +    </html>
          388  +  }
          389  +  incr G(cnt)
          390  +}
          391  +
          392  +proc wapp-default {} {
          393  +  generate_main_page
          394  +}
          395  +
          396  +proc wapp-page-control {} {
          397  +  global G
          398  +  foreach v {platform test tcl jobs keep msvc} {
          399  +    if {[wapp-param-exists control_$v]} {
          400  +      set G($v) [wapp-param control_$v]
          401  +    } else {
          402  +      set G($v) 0
          403  +    }
          404  +  }
          405  +
          406  +  if {[wapp-param-exists control_go]} {
          407  +    # This is an actual "run test" command, not just a change of 
          408  +    # configuration!
          409  +    set_test_array
          410  +    set ::G(state) "running"
          411  +  }
          412  +
          413  +  if {$::G(state) == "running"} {
          414  +    do_some_stuff
          415  +  }
          416  +
          417  +  wapp-redirect /
          418  +}
          419  +
          420  +proc wapp-page-style.css {} {
          421  +  wapp-subst {
          422  +    .div {
          423  +      border: 3px groove #444444;
          424  +      margin: 1em;
          425  +      padding: 1em;
          426  +    }
          427  +
          428  +    .warning {
          429  +      text-align:center;
          430  +      color: red;
          431  +      font-size: 2em;
          432  +      font-weight: bold;
          433  +    }
          434  +
          435  +    .right {
          436  +    }
          437  +
          438  +    .testfield {
          439  +      padding-right: 10ex;
          440  +    }
          441  +
          442  +    .testwait {}
          443  +    .testrunning { color: blue }
          444  +    .testdone { color: green }
          445  +    .testfail { color: red }
          446  +  }
          447  +}
          448  +
          449  +proc wapp-page-script.js {} {
          450  +
          451  +  set tcl $::G(tcl)
          452  +  set keep $::G(keep)
          453  +  set msvc $::G(msvc)
          454  +  
          455  +  wapp-subst {
          456  +    var lElem = \["control_platform", "control_test", "control_msvc", "control_jobs"\];
          457  +    lElem.forEach(function(e) {
          458  +      var elem = document.getElementById(e);
          459  +      elem.addEventListener("change", function() { control.submit() } );
          460  +    })
          461  +
          462  +    elem = document.getElementById("control_tcl");
          463  +    elem.value = "%string($tcl)"
          464  +
          465  +    elem = document.getElementById("control_keep");
          466  +    elem.checked = %string($keep);
          467  +
          468  +    elem = document.getElementById("control_msvc");
          469  +    elem.checked = %string($msvc);
          470  +  }
          471  +
          472  +  if {$::G(state)!="config"} {
          473  +    wapp-subst {
          474  +      var lElem = \["control_platform", "control_test", 
          475  +          "control_tcl", "control_keep", "control_msvc", "control_go"
          476  +      \];
          477  +      lElem.forEach(function(e) {
          478  +        var elem = document.getElementById(e);
          479  +        elem.disabled = true;
          480  +      })
          481  +    }
          482  +  }
          483  +}
          484  +
          485  +proc wapp-page-env {} {
          486  +  wapp-allow-xorigin-params
          487  +  wapp-trim {
          488  +    <h1>Wapp Environment</h1>\n<pre>
          489  +    <pre>%html([wapp-debug-env])</pre>
          490  +  }
          491  +}
          492  +
          493  +proc wapp-page-log {} {
          494  +  set log [string range [wapp-param REQUEST_URI] 5 end]
          495  +  set fd [open $log]
          496  +  set data [read $fd]
          497  +  close $fd
          498  +  wapp-trim {
          499  +    <pre>
          500  +    %html($data)
          501  +    </pre>
          502  +  }
          503  +}
          504  +
          505  +wapp-start $argv
          506  +