/ Changes On Branch wapptest
Login

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

Changes In Branch wapptest Excluding Merge-Ins

This is equivalent to a diff from d71f8bbc4e to d805fc0cf1

2019-04-11
19:07
Add the test/wapptest.tcl script, an alternative to releasetest.tcl that uses wapp to provide the user-interface. (check-in: edd87cd606 user: dan tags: trunk)
19:04
Merge trunk changes into this branch. (Closed-Leaf check-in: d805fc0cf1 user: dan tags: wapptest)
19:03
Further tweaks to wapptest.tcl. Add the ability to run the extra (n)debug tests that releasetest.tcl runs. (check-in: ec9c4f6d8d user: dan tags: wapptest)
17:06
Remove the vfslog.c extension from the testfixture target in main.mk, as that extension has no TCL bindings and is inaccessible. (check-in: d71f8bbc4e user: drh tags: trunk)
16:54
Fix RBU so that it does not write rows that should be excluded into partial indexes (corrupting the database). (check-in: 31eb27f438 user: dan tags: trunk)

Changes to Makefile.in.

  1368   1368   	$(LTLINK) $(TOP)/tool/loadfts.c libsqlite3.la -o $@ $(TLIBS)
  1369   1369   
  1370   1370   # This target will fail if the SQLite amalgamation contains any exported
  1371   1371   # symbols that do not begin with "sqlite3_". It is run as part of the
  1372   1372   # releasetest.tcl script.
  1373   1373   #
  1374   1374   VALIDIDS=' sqlite3(changeset|changegroup|session)?_'
  1375         -checksymbols: sqlite3.lo
  1376         -	nm -g --defined-only sqlite3.lo | egrep -v $(VALIDIDS); test $$? -ne 0
         1375  +checksymbols: sqlite3.o
         1376  +	nm -g --defined-only sqlite3.o
         1377  +	nm -g --defined-only sqlite3.o | egrep -v $(VALIDIDS); test $$? -ne 0
  1377   1378   	echo '0 errors out of 1 tests'
  1378   1379   
  1379   1380   # Build the amalgamation-autoconf package.  The amalamgation-tarball target builds
  1380   1381   # a tarball named for the version number.  Ex:  sqlite-autoconf-3110000.tar.gz.
  1381   1382   # The snapshot-tarball target builds a tarball named by the SHA1 hash
  1382   1383   #
  1383   1384   amalgamation-tarball: sqlite3.c

Added test/releasetest_data.tcl.

            1  +
            2  +# This file contains Configuration data used by "wapptest.tcl" and
            3  +# "releasetest.tcl".
            4  +#
            5  +
            6  +# Omit comments (text between # and \n) in a long multi-line string.
            7  +#
            8  +proc strip_comments {in} {
            9  +  regsub -all {#[^\n]*\n} $in {} out
           10  +  return $out
           11  +}
           12  +
           13  +array set ::Configs [strip_comments {
           14  +  "Default" {
           15  +    -O2
           16  +    --disable-amalgamation --disable-shared
           17  +    --enable-session
           18  +    -DSQLITE_ENABLE_DESERIALIZE
           19  +  }
           20  +  "Sanitize" {
           21  +    CC=clang -fsanitize=undefined
           22  +    -DSQLITE_ENABLE_STAT4
           23  +    --enable-session
           24  +  }
           25  +  "Stdcall" {
           26  +    -DUSE_STDCALL=1
           27  +    -O2
           28  +  }
           29  +  "Have-Not" {
           30  +    # The "Have-Not" configuration sets all possible -UHAVE_feature options
           31  +    # in order to verify that the code works even on platforms that lack
           32  +    # these support services.
           33  +    -DHAVE_FDATASYNC=0
           34  +    -DHAVE_GMTIME_R=0
           35  +    -DHAVE_ISNAN=0
           36  +    -DHAVE_LOCALTIME_R=0
           37  +    -DHAVE_LOCALTIME_S=0
           38  +    -DHAVE_MALLOC_USABLE_SIZE=0
           39  +    -DHAVE_STRCHRNUL=0
           40  +    -DHAVE_USLEEP=0
           41  +    -DHAVE_UTIME=0
           42  +  }
           43  +  "Unlock-Notify" {
           44  +    -O2
           45  +    -DSQLITE_ENABLE_UNLOCK_NOTIFY
           46  +    -DSQLITE_THREADSAFE
           47  +    -DSQLITE_TCL_DEFAULT_FULLMUTEX=1
           48  +  }
           49  +  "User-Auth" {
           50  +    -O2
           51  +    -DSQLITE_USER_AUTHENTICATION=1
           52  +  }
           53  +  "Secure-Delete" {
           54  +    -O2
           55  +    -DSQLITE_SECURE_DELETE=1
           56  +    -DSQLITE_SOUNDEX=1
           57  +  }
           58  +  "Update-Delete-Limit" {
           59  +    -O2
           60  +    -DSQLITE_DEFAULT_FILE_FORMAT=4
           61  +    -DSQLITE_ENABLE_UPDATE_DELETE_LIMIT=1
           62  +    -DSQLITE_ENABLE_STMT_SCANSTATUS
           63  +    -DSQLITE_LIKE_DOESNT_MATCH_BLOBS
           64  +    -DSQLITE_ENABLE_CURSOR_HINTS
           65  +    --enable-json1
           66  +  }
           67  +  "Check-Symbols" {
           68  +    -DSQLITE_MEMDEBUG=1
           69  +    -DSQLITE_ENABLE_FTS3_PARENTHESIS=1
           70  +    -DSQLITE_ENABLE_FTS3=1
           71  +    -DSQLITE_ENABLE_RTREE=1
           72  +    -DSQLITE_ENABLE_MEMSYS5=1
           73  +    -DSQLITE_ENABLE_MEMSYS3=1
           74  +    -DSQLITE_ENABLE_COLUMN_METADATA=1
           75  +    -DSQLITE_ENABLE_UPDATE_DELETE_LIMIT=1
           76  +    -DSQLITE_SECURE_DELETE=1
           77  +    -DSQLITE_SOUNDEX=1
           78  +    -DSQLITE_ENABLE_ATOMIC_WRITE=1
           79  +    -DSQLITE_ENABLE_MEMORY_MANAGEMENT=1
           80  +    -DSQLITE_ENABLE_OVERSIZE_CELL_CHECK=1
           81  +    -DSQLITE_ENABLE_STAT4
           82  +    -DSQLITE_ENABLE_STMT_SCANSTATUS
           83  +    --enable-json1 --enable-fts5 --enable-session
           84  +  }
           85  +  "Debug-One" {
           86  +    --disable-shared
           87  +    -O2 -funsigned-char
           88  +    -DSQLITE_DEBUG=1
           89  +    -DSQLITE_MEMDEBUG=1
           90  +    -DSQLITE_MUTEX_NOOP=1
           91  +    -DSQLITE_TCL_DEFAULT_FULLMUTEX=1
           92  +    -DSQLITE_ENABLE_FTS3=1
           93  +    -DSQLITE_ENABLE_RTREE=1
           94  +    -DSQLITE_ENABLE_MEMSYS5=1
           95  +    -DSQLITE_ENABLE_COLUMN_METADATA=1
           96  +    -DSQLITE_ENABLE_STAT4
           97  +    -DSQLITE_ENABLE_HIDDEN_COLUMNS
           98  +    -DSQLITE_MAX_ATTACHED=125
           99  +    -DSQLITE_MUTATION_TEST
          100  +    --enable-fts5 --enable-json1
          101  +  }
          102  +  "Fast-One" {
          103  +    -O6
          104  +    -DSQLITE_ENABLE_FTS4=1
          105  +    -DSQLITE_ENABLE_RTREE=1
          106  +    -DSQLITE_ENABLE_STAT4
          107  +    -DSQLITE_ENABLE_RBU
          108  +    -DSQLITE_MAX_ATTACHED=125
          109  +    -DLONGDOUBLE_TYPE=double
          110  +    --enable-session
          111  +  }
          112  +  "Device-One" {
          113  +    -O2
          114  +    -DSQLITE_DEBUG=1
          115  +    -DSQLITE_DEFAULT_AUTOVACUUM=1
          116  +    -DSQLITE_DEFAULT_CACHE_SIZE=64
          117  +    -DSQLITE_DEFAULT_PAGE_SIZE=1024
          118  +    -DSQLITE_DEFAULT_TEMP_CACHE_SIZE=32
          119  +    -DSQLITE_DISABLE_LFS=1
          120  +    -DSQLITE_ENABLE_ATOMIC_WRITE=1
          121  +    -DSQLITE_ENABLE_IOTRACE=1
          122  +    -DSQLITE_ENABLE_MEMORY_MANAGEMENT=1
          123  +    -DSQLITE_MAX_PAGE_SIZE=4096
          124  +    -DSQLITE_OMIT_LOAD_EXTENSION=1
          125  +    -DSQLITE_OMIT_PROGRESS_CALLBACK=1
          126  +    -DSQLITE_OMIT_VIRTUALTABLE=1
          127  +    -DSQLITE_ENABLE_HIDDEN_COLUMNS
          128  +    -DSQLITE_TEMP_STORE=3
          129  +    --enable-json1
          130  +  }
          131  +  "Device-Two" {
          132  +    -DSQLITE_4_BYTE_ALIGNED_MALLOC=1
          133  +    -DSQLITE_DEFAULT_AUTOVACUUM=1
          134  +    -DSQLITE_DEFAULT_CACHE_SIZE=1000
          135  +    -DSQLITE_DEFAULT_LOCKING_MODE=0
          136  +    -DSQLITE_DEFAULT_PAGE_SIZE=1024
          137  +    -DSQLITE_DEFAULT_TEMP_CACHE_SIZE=1000
          138  +    -DSQLITE_DISABLE_LFS=1
          139  +    -DSQLITE_ENABLE_FTS3=1
          140  +    -DSQLITE_ENABLE_MEMORY_MANAGEMENT=1
          141  +    -DSQLITE_ENABLE_RTREE=1
          142  +    -DSQLITE_MAX_COMPOUND_SELECT=50
          143  +    -DSQLITE_MAX_PAGE_SIZE=32768
          144  +    -DSQLITE_OMIT_TRACE=1
          145  +    -DSQLITE_TEMP_STORE=3
          146  +    -DSQLITE_THREADSAFE=2
          147  +    -DSQLITE_ENABLE_DESERIALIZE=1
          148  +    --enable-json1 --enable-fts5 --enable-session
          149  +  }
          150  +  "Locking-Style" {
          151  +    -O2
          152  +    -DSQLITE_ENABLE_LOCKING_STYLE=1
          153  +  }
          154  +  "Apple" {
          155  +    -Os
          156  +    -DHAVE_GMTIME_R=1
          157  +    -DHAVE_ISNAN=1
          158  +    -DHAVE_LOCALTIME_R=1
          159  +    -DHAVE_PREAD=1
          160  +    -DHAVE_PWRITE=1
          161  +    -DHAVE_USLEEP=1
          162  +    -DHAVE_USLEEP=1
          163  +    -DHAVE_UTIME=1
          164  +    -DSQLITE_DEFAULT_CACHE_SIZE=1000
          165  +    -DSQLITE_DEFAULT_CKPTFULLFSYNC=1
          166  +    -DSQLITE_DEFAULT_MEMSTATUS=1
          167  +    -DSQLITE_DEFAULT_PAGE_SIZE=1024
          168  +    -DSQLITE_DISABLE_PAGECACHE_OVERFLOW_STATS=1
          169  +    -DSQLITE_ENABLE_API_ARMOR=1
          170  +    -DSQLITE_ENABLE_AUTO_PROFILE=1
          171  +    -DSQLITE_ENABLE_FLOCKTIMEOUT=1
          172  +    -DSQLITE_ENABLE_FTS3=1
          173  +    -DSQLITE_ENABLE_FTS3_PARENTHESIS=1
          174  +    -DSQLITE_ENABLE_FTS3_TOKENIZER=1
          175  +    if:os=="Darwin" -DSQLITE_ENABLE_LOCKING_STYLE=1
          176  +    -DSQLITE_ENABLE_PERSIST_WAL=1
          177  +    -DSQLITE_ENABLE_PURGEABLE_PCACHE=1
          178  +    -DSQLITE_ENABLE_RTREE=1
          179  +    -DSQLITE_ENABLE_SNAPSHOT=1
          180  +    # -DSQLITE_ENABLE_SQLLOG=1
          181  +    -DSQLITE_ENABLE_UPDATE_DELETE_LIMIT=1
          182  +    -DSQLITE_MAX_LENGTH=2147483645
          183  +    -DSQLITE_MAX_VARIABLE_NUMBER=500000
          184  +    # -DSQLITE_MEMDEBUG=1
          185  +    -DSQLITE_NO_SYNC=1
          186  +    -DSQLITE_OMIT_AUTORESET=1
          187  +    -DSQLITE_OMIT_LOAD_EXTENSION=1
          188  +    -DSQLITE_PREFER_PROXY_LOCKING=1
          189  +    -DSQLITE_SERIES_CONSTRAINT_VERIFY=1
          190  +    -DSQLITE_THREADSAFE=2
          191  +    -DSQLITE_USE_URI=1
          192  +    -DSQLITE_WRITE_WALFRAME_PREBUFFERED=1
          193  +    -DUSE_GUARDED_FD=1
          194  +    -DUSE_PREAD=1
          195  +    --enable-json1 --enable-fts5
          196  +  }
          197  +  "Extra-Robustness" {
          198  +    -DSQLITE_ENABLE_OVERSIZE_CELL_CHECK=1
          199  +    -DSQLITE_MAX_ATTACHED=62
          200  +  }
          201  +  "Devkit" {
          202  +    -DSQLITE_DEFAULT_FILE_FORMAT=4
          203  +    -DSQLITE_MAX_ATTACHED=30
          204  +    -DSQLITE_ENABLE_COLUMN_METADATA
          205  +    -DSQLITE_ENABLE_FTS4
          206  +    -DSQLITE_ENABLE_FTS5
          207  +    -DSQLITE_ENABLE_FTS4_PARENTHESIS
          208  +    -DSQLITE_DISABLE_FTS4_DEFERRED
          209  +    -DSQLITE_ENABLE_RTREE
          210  +    --enable-json1 --enable-fts5
          211  +  }
          212  +  "No-lookaside" {
          213  +    -DSQLITE_TEST_REALLOC_STRESS=1
          214  +    -DSQLITE_OMIT_LOOKASIDE=1
          215  +    -DHAVE_USLEEP=1
          216  +  }
          217  +  "Valgrind" {
          218  +    -DSQLITE_ENABLE_STAT4
          219  +    -DSQLITE_ENABLE_FTS4
          220  +    -DSQLITE_ENABLE_RTREE
          221  +    -DSQLITE_ENABLE_HIDDEN_COLUMNS
          222  +    --enable-json1
          223  +  }
          224  +
          225  +  # The next group of configurations are used only by the
          226  +  # Failure-Detection platform.  They are all the same, but we need
          227  +  # different names for them all so that they results appear in separate
          228  +  # subdirectories.
          229  +  #
          230  +  Fail0 {-O0}
          231  +  Fail2 {-O0}
          232  +  Fail3 {-O0}
          233  +  Fail4 {-O0}
          234  +  FuzzFail1 {-O0}
          235  +  FuzzFail2 {-O0}
          236  +}]
          237  +
          238  +array set ::Platforms [strip_comments {
          239  +  Linux-x86_64 {
          240  +    "Check-Symbols"           checksymbols
          241  +    "Fast-One"                "fuzztest test"
          242  +    "Debug-One"               "mptest test"
          243  +    "Have-Not"                test
          244  +    "Secure-Delete"           test
          245  +    "Unlock-Notify"           "QUICKTEST_INCLUDE=notify2.test test"
          246  +    "User-Auth"               tcltest
          247  +    "Update-Delete-Limit"     test
          248  +    "Extra-Robustness"        test
          249  +    "Device-Two"              test
          250  +    "No-lookaside"            test
          251  +    "Devkit"                  test
          252  +    "Apple"                   test
          253  +    "Sanitize"                {QUICKTEST_OMIT=func4.test,nan.test test}
          254  +    "Device-One"              fulltest
          255  +    "Default"                 "threadtest fulltest"
          256  +    "Valgrind"                valgrindtest
          257  +  }
          258  +  Linux-i686 {
          259  +    "Devkit"                  test
          260  +    "Have-Not"                test
          261  +    "Unlock-Notify"           "QUICKTEST_INCLUDE=notify2.test test"
          262  +    "Device-One"              test
          263  +    "Device-Two"              test
          264  +    "Default"                 "threadtest fulltest"
          265  +  }
          266  +  Darwin-i386 {
          267  +    "Locking-Style"           "mptest test"
          268  +    "Have-Not"                test
          269  +    "Apple"                   "threadtest fulltest"
          270  +  }
          271  +  Darwin-x86_64 {
          272  +    "Locking-Style"           "mptest test"
          273  +    "Have-Not"                test
          274  +    "Apple"                   "threadtest fulltest"
          275  +  }
          276  +  "Windows NT-intel" {
          277  +    "Stdcall"                 test
          278  +    "Have-Not"                test
          279  +    "Default"                 "mptest fulltestonly"
          280  +  }
          281  +  "Windows NT-amd64" {
          282  +    "Stdcall"                 test
          283  +    "Have-Not"                test
          284  +    "Default"                 "mptest fulltestonly"
          285  +  }
          286  +
          287  +  # The Failure-Detection platform runs various tests that deliberately
          288  +  # fail.  This is used as a test of this script to verify that this script
          289  +  # correctly identifies failures.
          290  +  #
          291  +  Failure-Detection {
          292  +    Fail0     "TEST_FAILURE=0 test"
          293  +    Sanitize  "TEST_FAILURE=1 test"
          294  +    Fail2     "TEST_FAILURE=2 valgrindtest"
          295  +    Fail3     "TEST_FAILURE=3 valgrindtest"
          296  +    Fail4     "TEST_FAILURE=4 test"
          297  +    FuzzFail1 "TEST_FAILURE=5 test"
          298  +    FuzzFail2 "TEST_FAILURE=5 valgrindtest"
          299  +  }
          300  +}]
          301  +
          302  +proc make_test_suite {msvc withtcl name testtarget config} {
          303  +
          304  +  # Tcl variable $opts is used to build up the value used to set the
          305  +  # OPTS Makefile variable. Variable $cflags holds the value for
          306  +  # CFLAGS. The makefile will pass OPTS to both gcc and lemon, but
          307  +  # CFLAGS is only passed to gcc.
          308  +  #
          309  +  set makeOpts ""
          310  +  set cflags [expr {$msvc ? "-Zi" : "-g"}]
          311  +  set opts ""
          312  +  set title ${name}($testtarget)
          313  +  set configOpts $withtcl
          314  +  set skip 0
          315  +
          316  +  regsub -all {#[^\n]*\n} $config \n config
          317  +  foreach arg $config {
          318  +    if {$skip} {
          319  +      set skip 0
          320  +      continue
          321  +    }
          322  +    if {[regexp {^-[UD]} $arg]} {
          323  +      lappend opts $arg
          324  +    } elseif {[regexp {^[A-Z]+=} $arg]} {
          325  +      lappend testtarget $arg
          326  +    } elseif {[regexp {^if:([a-z]+)(.*)} $arg all key tail]} {
          327  +      # Arguments of the form 'if:os=="Linux"' will cause the subsequent
          328  +      # argument to be skipped if the $tcl_platform(os) is not "Linux", for
          329  +      # example...
          330  +      set skip [expr !(\$::tcl_platform($key)$tail)]
          331  +    } elseif {[regexp {^--(enable|disable)-} $arg]} {
          332  +      if {$msvc} {
          333  +        if {$arg eq "--disable-amalgamation"} {
          334  +          lappend makeOpts USE_AMALGAMATION=0
          335  +          continue
          336  +        }
          337  +        if {$arg eq "--disable-shared"} {
          338  +          lappend makeOpts USE_CRT_DLL=0 DYNAMIC_SHELL=0
          339  +          continue
          340  +        }
          341  +        if {$arg eq "--enable-fts5"} {
          342  +          lappend opts -DSQLITE_ENABLE_FTS5
          343  +          continue
          344  +        }
          345  +        if {$arg eq "--enable-json1"} {
          346  +          lappend opts -DSQLITE_ENABLE_JSON1
          347  +          continue
          348  +        }
          349  +        if {$arg eq "--enable-shared"} {
          350  +          lappend makeOpts USE_CRT_DLL=1 DYNAMIC_SHELL=1
          351  +          continue
          352  +        }
          353  +      }
          354  +      lappend configOpts $arg
          355  +    } else {
          356  +      if {$msvc} {
          357  +        if {$arg eq "-g"} {
          358  +          lappend cflags -Zi
          359  +          continue
          360  +        }
          361  +        if {[regexp -- {^-O(\d+)$} $arg all level]} then {
          362  +          lappend makeOpts OPTIMIZATIONS=$level
          363  +          continue
          364  +        }
          365  +      }
          366  +      lappend cflags $arg
          367  +    }
          368  +  }
          369  +
          370  +  # Disable sync to make testing faster.
          371  +  #
          372  +  lappend opts -DSQLITE_NO_SYNC=1
          373  +
          374  +  # Some configurations already set HAVE_USLEEP; in that case, skip it.
          375  +  #
          376  +  if {[lsearch -regexp $opts {^-DHAVE_USLEEP(?:=|$)}]==-1} {
          377  +    lappend opts -DHAVE_USLEEP=1
          378  +  }
          379  +
          380  +  # Add the define for this platform.
          381  +  #
          382  +  if {$::tcl_platform(platform)=="windows"} {
          383  +    lappend opts -DSQLITE_OS_WIN=1
          384  +  } else {
          385  +    lappend opts -DSQLITE_OS_UNIX=1
          386  +  }
          387  +
          388  +  # Set the sub-directory to use.
          389  +  #
          390  +  set dir [string tolower [string map {- _ " " _ "(" _ ")" _} $name]]
          391  +
          392  +  # Join option lists into strings, using space as delimiter.
          393  +  #
          394  +  set makeOpts [join $makeOpts " "]
          395  +  set cflags   [join $cflags " "]
          396  +  set opts     [join $opts " "]
          397  +
          398  +  return [list $title $dir $configOpts $testtarget $makeOpts $cflags $opts]
          399  +}
          400  +
          401  +# Configuration verification: Check that each entry in the list of configs
          402  +# specified for each platforms exists.
          403  +#
          404  +foreach {key value} [array get ::Platforms] {
          405  +  foreach {v t} $value {
          406  +    if {0==[info exists ::Configs($v)]} {
          407  +      puts stderr "No such configuration: \"$v\""
          408  +      exit -1
          409  +    }
          410  +  }
          411  +}
          412  +

Added test/wapp.tcl.

            1  +# Copyright (c) 2017 D. Richard Hipp
            2  +# 
            3  +# This program is free software; you can redistribute it and/or
            4  +# modify it under the terms of the Simplified BSD License (also
            5  +# known as the "2-Clause License" or "FreeBSD License".)
            6  +#
            7  +# This program is distributed in the hope that it will be useful,
            8  +# but without any warranty; without even the implied warranty of
            9  +# merchantability or fitness for a particular purpose.
           10  +#
           11  +#---------------------------------------------------------------------------
           12  +#
           13  +# Design rules:
           14  +#
           15  +#   (1)  All identifiers in the global namespace begin with "wapp"
           16  +#
           17  +#   (2)  Indentifiers intended for internal use only begin with "wappInt"
           18  +#
           19  +package require Tcl 8.6
           20  +
           21  +# Add text to the end of the HTTP reply.  No interpretation or transformation
           22  +# of the text is performs.  The argument should be enclosed within {...}
           23  +#
           24  +proc wapp {txt} {
           25  +  global wapp
           26  +  dict append wapp .reply $txt
           27  +}
           28  +
           29  +# Add text to the page under construction.  Do no escaping on the text.
           30  +#
           31  +# Though "unsafe" in general, there are uses for this kind of thing.
           32  +# For example, if you want to return the complete, unmodified content of
           33  +# a file:
           34  +#
           35  +#         set fd [open content.html rb]
           36  +#         wapp-unsafe [read $fd]
           37  +#         close $fd
           38  +#
           39  +# You could do the same thing using ordinary "wapp" instead of "wapp-unsafe".
           40  +# The difference is that wapp-safety-check will complain about the misuse
           41  +# of "wapp", but it assumes that the person who write "wapp-unsafe" understands
           42  +# the risks.
           43  +#
           44  +# Though occasionally necessary, the use of this interface should be minimized.
           45  +#
           46  +proc wapp-unsafe {txt} {
           47  +  global wapp
           48  +  dict append wapp .reply $txt
           49  +}
           50  +
           51  +# Add text to the end of the reply under construction.  The following
           52  +# substitutions are made:
           53  +#
           54  +#     %html(...)          Escape text for inclusion in HTML
           55  +#     %url(...)           Escape text for use as a URL
           56  +#     %qp(...)            Escape text for use as a URI query parameter
           57  +#     %string(...)        Escape text for use within a JSON string
           58  +#     %unsafe(...)        No transformations of the text
           59  +#
           60  +# The substitutions above terminate at the first ")" character.  If the
           61  +# text of the TCL string in ... contains ")" characters itself, use instead:
           62  +#
           63  +#     %html%(...)%
           64  +#     %url%(...)%
           65  +#     %qp%(...)%
           66  +#     %string%(...)%
           67  +#     %unsafe%(...)%
           68  +#
           69  +# In other words, use "%(...)%" instead of "(...)" to include the TCL string
           70  +# to substitute.
           71  +#
           72  +# The %unsafe substitution should be avoided whenever possible, obviously.
           73  +# In addition to the substitutions above, the text also does backslash
           74  +# escapes.
           75  +#
           76  +# The wapp-trim proc works the same as wapp-subst except that it also removes
           77  +# whitespace from the left margin, so that the generated HTML/CSS/Javascript
           78  +# does not appear to be indented when delivered to the client web browser.
           79  +#
           80  +if {$tcl_version>=8.7} {
           81  +  proc wapp-subst {txt} {
           82  +    global wapp
           83  +    regsub -all -command \
           84  +       {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt wappInt-enc txt
           85  +    dict append wapp .reply [subst -novariables -nocommand $txt]
           86  +  }
           87  +  proc wapp-trim {txt} {
           88  +    global wapp
           89  +    regsub -all {\n\s+} [string trim $txt] \n txt
           90  +    regsub -all -command \
           91  +       {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt wappInt-enc txt
           92  +    dict append wapp .reply [subst -novariables -nocommand $txt]
           93  +  }
           94  +  proc wappInt-enc {all mode nu1 txt} {
           95  +    return [uplevel 2 "wappInt-enc-$mode \"$txt\""]
           96  +  }
           97  +} else {
           98  +  proc wapp-subst {txt} {
           99  +    global wapp
          100  +    regsub -all {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt \
          101  +           {[wappInt-enc-\1 "\3"]} txt
          102  +    dict append wapp .reply [uplevel 1 [list subst -novariables $txt]]
          103  +  }
          104  +  proc wapp-trim {txt} {
          105  +    global wapp
          106  +    regsub -all {\n\s+} [string trim $txt] \n txt
          107  +    regsub -all {%(html|url|qp|string|unsafe){1,1}?(|%)\((.+)\)\2} $txt \
          108  +           {[wappInt-enc-\1 "\3"]} txt
          109  +    dict append wapp .reply [uplevel 1 [list subst -novariables $txt]]
          110  +  }
          111  +}
          112  +
          113  +# There must be a wappInt-enc-NAME routine for each possible substitution
          114  +# in wapp-subst.  Thus there are routines for "html", "url", "qp", and "unsafe".
          115  +#
          116  +#    wappInt-enc-html           Escape text so that it is safe to use in the
          117  +#                               body of an HTML document.
          118  +#
          119  +#    wappInt-enc-url            Escape text so that it is safe to pass as an
          120  +#                               argument to href= and src= attributes in HTML.
          121  +#
          122  +#    wappInt-enc-qp             Escape text so that it is safe to use as the
          123  +#                               value of a query parameter in a URL or in
          124  +#                               post data or in a cookie.
          125  +#
          126  +#    wappInt-enc-string         Escape ", ', \, and < for using inside of a
          127  +#                               javascript string literal.  The < character
          128  +#                               is escaped to prevent "</script>" from causing
          129  +#                               problems in embedded javascript.
          130  +#
          131  +#    wappInt-enc-unsafe         Perform no encoding at all.  Unsafe.
          132  +#
          133  +proc wappInt-enc-html {txt} {
          134  +  return [string map {& &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  +# package required wapp
            6  +source [file join [file dirname [info script]] wapp.tcl]
            7  +
            8  +# Read the data from the releasetest_data.tcl script.
            9  +#
           10  +source [file join [file dirname [info script]] releasetest_data.tcl]
           11  +
           12  +# Variables set by the "control" form:
           13  +#
           14  +#   G(platform) - User selected platform.
           15  +#   G(test)     - Set to "Normal", "Veryquick", "Smoketest" or "Build-Only".
           16  +#   G(keep)     - Boolean. True to delete no files after each test.
           17  +#   G(msvc)     - Boolean. True to use MSVC as the compiler.
           18  +#   G(tcl)      - Use Tcl from this directory for builds.
           19  +#   G(jobs)     - How many sub-processes to run simultaneously.
           20  +#
           21  +set G(platform) $::tcl_platform(os)-$::tcl_platform(machine)
           22  +set G(test)     Normal
           23  +set G(keep)     0
           24  +set G(msvc)     0
           25  +set G(tcl)      [::tcl::pkgconfig get libdir,install]
           26  +set G(jobs)     3
           27  +set G(debug)    0
           28  +
           29  +proc wapptest_init {} {
           30  +  global G
           31  +
           32  +  set lSave [list platform test keep msvc tcl jobs debug] 
           33  +  foreach k $lSave { set A($k) $G($k) }
           34  +  array unset G
           35  +  foreach k $lSave { set G($k) $A($k) }
           36  +
           37  +  # The root of the SQLite source tree.
           38  +  set G(srcdir)   [file dirname [file dirname [info script]]]
           39  +
           40  +  # releasetest.tcl script
           41  +  set G(releaseTest) [file join [file dirname [info script]] releasetest.tcl]
           42  +
           43  +  set G(sqlite_version) "unknown"
           44  +
           45  +  # Either "config", "running" or "stopped":
           46  +  set G(state) "config"
           47  +
           48  +  set G(hostname) "(unknown host)"
           49  +  catch { set G(hostname) [exec hostname] } 
           50  +  set G(host) $G(hostname)
           51  +  append G(host) " $::tcl_platform(os) $::tcl_platform(osVersion)"
           52  +  append G(host) " $::tcl_platform(machine) $::tcl_platform(byteOrder)"
           53  +}
           54  +
           55  +# Check to see if there are uncommitted changes in the SQLite source
           56  +# directory. Return true if there are, or false otherwise.
           57  +#
           58  +proc check_uncommitted {} {
           59  +  global G
           60  +  set ret 0
           61  +  set pwd [pwd]
           62  +  cd $G(srcdir)
           63  +  if {[catch {exec fossil changes} res]==0 && [string trim $res]!=""} {
           64  +    set ret 1
           65  +  }
           66  +  cd $pwd
           67  +  return $ret
           68  +}
           69  +
           70  +proc generate_fossil_info {} {
           71  +  global G
           72  +  set pwd [pwd]
           73  +  cd $G(srcdir)
           74  +  if {[catch {exec fossil info}    r1]} return
           75  +  if {[catch {exec fossil changes} r2]} return
           76  +  cd $pwd
           77  +
           78  +  foreach line [split $r1 "\n"] {
           79  +    if {[regexp {^checkout: *(.*)$} $line -> co]} {
           80  +      wapp-trim { <br> %html($co) }
           81  +    }
           82  +  }
           83  +
           84  +  if {[string trim $r2]!=""} {
           85  +    wapp-trim { 
           86  +      <br><span class=warning> 
           87  +      WARNING: Uncommitted changes in checkout
           88  +      </span>
           89  +    }
           90  +  }
           91  +}
           92  +
           93  +# If the application is in "config" state, set the contents of the 
           94  +# ::G(test_array) global to reflect the tests that will be run. If the
           95  +# app is in some other state ("running" or "stopped"), this command
           96  +# is a no-op.
           97  +#
           98  +proc set_test_array {} {
           99  +  global G
          100  +  if { $G(state)=="config" } {
          101  +    set G(test_array) [list]
          102  +    foreach {config target} $::Platforms($G(platform)) {
          103  +
          104  +      # If using MSVC, do not run sanitize or valgrind tests. Or the
          105  +      # checksymbols test.
          106  +      if {$G(msvc) && (
          107  +          "Sanitize" == $config 
          108  +       || "checksymbols" in $target
          109  +       || "valgrindtest" in $target
          110  +      )} {
          111  +        continue
          112  +      }
          113  +
          114  +      # If the test mode is not "Normal", override the target.
          115  +      #
          116  +      if {$target!="checksymbols" && $G(platform)!="Failure-Detection"} {
          117  +        switch -- $G(test) {
          118  +          Veryquick { set target quicktest }
          119  +          Smoketest { set target smoketest }
          120  +          Build-Only {
          121  +            set target testfixture
          122  +            if {$::tcl_platform(platform)=="windows"} {
          123  +              set target testfixture.exe
          124  +            }
          125  +          }
          126  +        }
          127  +      }
          128  +
          129  +      lappend G(test_array) [dict create config $config target $target]
          130  +
          131  +      set exclude [list checksymbols valgrindtest fuzzoomtest]
          132  +      if {$G(debug) && !($target in $exclude)} {
          133  +        set debug_idx [lsearch -glob $::Configs($config) -DSQLITE_DEBUG*]
          134  +        set xtarget $target
          135  +        regsub -all {fulltest[a-z]*} $xtarget test xtarget
          136  +        if {$debug_idx<0} {
          137  +          lappend G(test_array) [
          138  +            dict create config $config-(Debug) target $target
          139  +          ]
          140  +        } else {
          141  +          lappend G(test_array) [
          142  +            dict create config $config-(NDebug) target $xtarget
          143  +          ]
          144  +        }
          145  +      }
          146  +    }
          147  +  }
          148  +}
          149  +
          150  +proc count_tests_and_errors {name logfile} {
          151  +  global G
          152  +
          153  +  set fd [open $logfile rb]
          154  +  set seen 0
          155  +  while {![eof $fd]} {
          156  +    set line [gets $fd]
          157  +    if {[regexp {(\d+) errors out of (\d+) tests} $line all nerr ntest]} {
          158  +      incr G(test.$name.nError) $nerr
          159  +      incr G(test.$name.nTest) $ntest
          160  +      set seen 1
          161  +      if {$nerr>0} {
          162  +        set G(test.$name.errmsg) $line
          163  +      }
          164  +    }
          165  +    if {[regexp {runtime error: +(.*)} $line all msg]} {
          166  +      # skip over "value is outside range" errors
          167  +      if {[regexp {value .* is outside the range of representable} $line]} {
          168  +         # noop
          169  +      } else {
          170  +        incr G(test.$name.nError)
          171  +        if {$G(test.$name.errmsg)==""} {
          172  +          set G(test.$name.errmsg) $msg
          173  +        }
          174  +      }
          175  +    }
          176  +    if {[regexp {fatal error +(.*)} $line all msg]} {
          177  +      incr G(test.$name.nError)
          178  +      if {$G(test.$name.errmsg)==""} {
          179  +        set G(test.$name.errmsg) $msg
          180  +      }
          181  +    }
          182  +    if {[regexp {ERROR SUMMARY: (\d+) errors.*} $line all cnt] && $cnt>0} {
          183  +      incr G(test.$name.nError)
          184  +      if {$G(test.$name.errmsg)==""} {
          185  +        set G(test.$name.errmsg) $all
          186  +      }
          187  +    }
          188  +    if {[regexp {^VERSION: 3\.\d+.\d+} $line]} {
          189  +      set v [string range $line 9 end]
          190  +      if {$G(sqlite_version) eq "unknown"} {
          191  +        set G(sqlite_version) $v
          192  +      } elseif {$G(sqlite_version) ne $v} {
          193  +        set G(test.$name.errmsg) "version conflict: {$G(sqlite_version)} vs. {$v}"
          194  +      }
          195  +    }
          196  +  }
          197  +  close $fd
          198  +  if {$G(test) == "Build-Only"} {
          199  +    incr G(test.$name.nTest)
          200  +    if {$G(test.$name.nError)>0} {
          201  +      set errmsg "Build failed"
          202  +    }
          203  +  } elseif {!$seen} {
          204  +    set G(test.$name.errmsg) "Test did not complete"
          205  +    if {[file readable core]} {
          206  +      append G(test.$name.errmsg) " - core file exists"
          207  +    }
          208  +  }
          209  +}
          210  +
          211  +proc slave_test_done {name rc} {
          212  +  global G
          213  +  set G(test.$name.done) [clock seconds]
          214  +  set G(test.$name.nError) 0
          215  +  set G(test.$name.nTest) 0
          216  +  set G(test.$name.errmsg) ""
          217  +  if {$rc} {
          218  +    incr G(test.$name.nError)
          219  +  }
          220  +  if {[file exists $G(test.$name.log)]} {
          221  +    count_tests_and_errors $name $G(test.$name.log)
          222  +  }
          223  +}
          224  +
          225  +proc slave_fileevent {name} {
          226  +  global G
          227  +  set fd $G(test.$name.channel)
          228  +
          229  +  if {[eof $fd]} {
          230  +    fconfigure $fd -blocking 1
          231  +    set rc [catch { close $fd }]
          232  +    unset G(test.$name.channel)
          233  +    slave_test_done $name $rc
          234  +  } else {
          235  +    set line [gets $fd]
          236  +    if {[string trim $line] != ""} { puts "Trace   : $name - \"$line\"" }
          237  +  }
          238  +
          239  +  do_some_stuff
          240  +}
          241  +
          242  +proc do_some_stuff {} {
          243  +  global G
          244  +
          245  +  # Count the number of running jobs. A running job has an entry named
          246  +  # "channel" in its dictionary.
          247  +  set nRunning 0
          248  +  set bFinished 1
          249  +  foreach j $G(test_array) {
          250  +    set name [dict get $j config]
          251  +    if { [info exists G(test.$name.channel)]} { incr nRunning   }
          252  +    if {![info exists G(test.$name.done)]}    { set bFinished 0 }
          253  +  }
          254  +
          255  +  if {$bFinished} {
          256  +    set nError 0
          257  +    set nTest 0
          258  +    set nConfig 0
          259  +    foreach j $G(test_array) {
          260  +      set name [dict get $j config]
          261  +      incr nError $G(test.$name.nError)
          262  +      incr nTest $G(test.$name.nTest)
          263  +      incr nConfig 
          264  +    }
          265  +    set G(result) "$nError errors from $nTest tests in $nConfig configurations."
          266  +    catch {
          267  +      append G(result) " SQLite version $G(sqlite_version)"
          268  +    }
          269  +    set G(state) "stopped"
          270  +  } else {
          271  +    set nLaunch [expr $G(jobs) - $nRunning]
          272  +    foreach j $G(test_array) {
          273  +      if {$nLaunch<=0} break
          274  +      set name [dict get $j config]
          275  +      if { ![info exists G(test.$name.channel)]
          276  +        && ![info exists G(test.$name.done)]
          277  +      } {
          278  +        set target [dict get $j target]
          279  +        set G(test.$name.start) [clock seconds]
          280  +        set fd [open "|[info nameofexecutable] $G(releaseTest) --slave" r+]
          281  +        set G(test.$name.channel) $fd
          282  +        fconfigure $fd -blocking 0
          283  +        fileevent $fd readable [list slave_fileevent $name]
          284  +
          285  +        puts $fd [list 0 $G(msvc) 0 $G(keep)]
          286  +
          287  +        set wtcl ""
          288  +        if {$G(tcl)!=""} { set wtcl "--with-tcl=$G(tcl)" }
          289  +
          290  +        # If this configuration is named <name>-(Debug) or <name>-(NDebug),
          291  +        # then add or remove the SQLITE_DEBUG option from the base
          292  +        # configuration before running the test.
          293  +        if {[regexp -- {(.*)-(\(.*\))} $name -> head tail]} {
          294  +          set opts $::Configs($head)
          295  +          if {$tail=="(Debug)"} {
          296  +            append opts " -DSQLITE_DEBUG=1 -DSQLITE_EXTRA_IFNULLROW=1"
          297  +          } else {
          298  +            regsub { *-DSQLITE_MEMDEBUG[^ ]* *} $opts { } opts
          299  +            regsub { *-DSQLITE_DEBUG[^ ]* *} $opts { } opts
          300  +          }
          301  +        } else {
          302  +          set opts $::Configs($name)
          303  +        }
          304  +
          305  +        set L [make_test_suite $G(msvc) $wtcl $name $target $opts]
          306  +        puts $fd $L
          307  +        flush $fd
          308  +        set G(test.$name.log) [file join [lindex $L 1] test.log]
          309  +        incr nLaunch -1
          310  +      }
          311  +    }
          312  +  }
          313  +}
          314  +
          315  +proc generate_select_widget {label id lOpt opt} {
          316  +  wapp-trim {
          317  +    <label> %string($label) </label>
          318  +    <select id=%string($id) name=%string($id)>
          319  +  }
          320  +  foreach o $lOpt {
          321  +    set selected ""
          322  +    if {$o==$opt} { set selected " selected=1" }
          323  +    wapp-subst "<option $selected>$o</option>"
          324  +  }
          325  +  wapp-trim { </select> }
          326  +}
          327  +
          328  +proc generate_main_page {{extra {}}} {
          329  +  global G
          330  +  set_test_array
          331  +
          332  +  set hostname $G(hostname)
          333  +  wapp-trim {
          334  +    <html>
          335  +    <head>
          336  +      <title> %html($hostname): wapptest.tcl </title>
          337  +      <link rel="stylesheet" type="text/css" href="style.css"/>
          338  +    </head>
          339  +    <body>
          340  +  }
          341  +
          342  +  set host $G(host)
          343  +  wapp-trim {
          344  +    <div class="border">%string($host)
          345  +  }
          346  +  generate_fossil_info
          347  +  wapp-trim {
          348  +    </div>
          349  +    <div class="border" id=controls> 
          350  +    <form action="control" method="post" name="control">
          351  +  }
          352  +
          353  +  # Build the "platform" select widget. 
          354  +  set lOpt [array names ::Platforms]
          355  +  generate_select_widget Platform control_platform $lOpt $G(platform)
          356  +
          357  +  # Build the "test" select widget. 
          358  +  set lOpt [list Normal Veryquick Smoketest Build-Only] 
          359  +  generate_select_widget Test control_test $lOpt $G(test)
          360  +
          361  +  # Build the "jobs" select widget. Options are 1 to 8.
          362  +  generate_select_widget Jobs control_jobs {1 2 3 4 5 6 7 8} $G(jobs)
          363  +
          364  +  switch $G(state) {
          365  +    config {
          366  +      set txt "Run Tests!"
          367  +      set id control_run
          368  +    }
          369  +    running {
          370  +      set txt "STOP Tests!"
          371  +      set id control_stop
          372  +    }
          373  +    stopped {
          374  +      set txt "Reset!"
          375  +      set id control_reset
          376  +    }
          377  +  }
          378  +  wapp-trim {
          379  +    <div class=right>
          380  +    <input id=%string($id) name=%string($id) type=submit value="%string($txt)">
          381  +    </input>
          382  +    </div>
          383  +  }
          384  +
          385  +  wapp-trim {
          386  +  <br><br>
          387  +        <label> Tcl: </label>
          388  +        <input id="control_tcl" name="control_tcl"></input>
          389  +        <label> Keep files: </label>
          390  +        <input id="control_keep" name="control_keep" type=checkbox value=1>
          391  +        </input>
          392  +        <label> Use MSVC: </label>
          393  +        <input id="control_msvc" name="control_msvc" type=checkbox value=1>
          394  +        <label> Debug tests: </label>
          395  +        <input id="control_debug" name="control_debug" type=checkbox value=1>
          396  +        </input>
          397  +  }
          398  +  wapp-trim {
          399  +     </form>
          400  +  }
          401  +  wapp-trim {
          402  +     </div>
          403  +     <div id=tests>
          404  +  }
          405  +  wapp-page-tests
          406  +
          407  +  set script "script/$G(state).js"
          408  +  wapp-trim {
          409  +    </div>
          410  +      <script src=%string($script)></script>
          411  +    </body>
          412  +    </html>
          413  +  }
          414  +}
          415  +
          416  +proc wapp-default {} {
          417  +  generate_main_page
          418  +}
          419  +
          420  +proc wapp-page-tests {} {
          421  +  global G
          422  +  wapp-trim { <table class="border" width=100%> }
          423  +  foreach t $G(test_array) {
          424  +    set config [dict get $t config]
          425  +    set target [dict get $t target]
          426  +
          427  +    set class "testwait"
          428  +    set seconds ""
          429  +
          430  +    if {[info exists G(test.$config.log)]} {
          431  +      if {[info exists G(test.$config.channel)]} {
          432  +        set class "testrunning"
          433  +        set seconds [expr [clock seconds] - $G(test.$config.start)]
          434  +      } elseif {[info exists G(test.$config.done)]} {
          435  +        if {$G(test.$config.nError)>0} {
          436  +          set class "testfail" 
          437  +        } else {
          438  +          set class "testdone"
          439  +        }
          440  +        set seconds [expr $G(test.$config.done) - $G(test.$config.start)]
          441  +      }
          442  +
          443  +      set min [format %.2d [expr ($seconds / 60) % 60]]
          444  +      set  hr [format %.2d [expr $seconds / 3600]]
          445  +      set sec [format %.2d [expr $seconds % 60]]
          446  +      set seconds "$hr:$min:$sec"
          447  +    }
          448  +
          449  +    wapp-trim {
          450  +      <tr class=%string($class)>
          451  +      <td class="nowrap"> %html($config) 
          452  +      <td class="padleft nowrap"> %html($target)
          453  +      <td class="padleft nowrap"> %html($seconds)
          454  +      <td class="padleft nowrap">
          455  +    }
          456  +    if {[info exists G(test.$config.log)]} {
          457  +      set log $G(test.$config.log)
          458  +      set uri "log/$log"
          459  +      wapp-trim {
          460  +        <a href=%url($uri)> %html($log) </a>
          461  +      }
          462  +    }
          463  +    if {[info exists G(test.$config.errmsg)] && $G(test.$config.errmsg)!=""} {
          464  +      set errmsg $G(test.$config.errmsg)
          465  +      wapp-trim {
          466  +        <tr class=testfail>
          467  +        <td> <td class="padleft" colspan=3> %html($errmsg)
          468  +      }
          469  +    }
          470  +  }
          471  +
          472  +  wapp-trim { </table> }
          473  +
          474  +  if {[info exists G(result)]} {
          475  +    set res $G(result)
          476  +    wapp-trim {
          477  +      <div class=border id=result> %string($res) </div>
          478  +    }
          479  +  }
          480  +}
          481  +
          482  +# URI: /control
          483  +#
          484  +# Whenever the form at the top of the application page is submitted, it
          485  +# is submitted here.
          486  +#
          487  +proc wapp-page-control {} {
          488  +  global G
          489  +  if {$::G(state)=="config"} {
          490  +    set lControls [list platform test tcl jobs keep msvc debug]
          491  +    set G(msvc) 0
          492  +    set G(keep) 0
          493  +    set G(debug) 0
          494  +  } else {
          495  +    set lControls [list jobs]
          496  +  }
          497  +  foreach v $lControls {
          498  +    if {[wapp-param-exists control_$v]} {
          499  +      set G($v) [wapp-param control_$v]
          500  +    }
          501  +  }
          502  +
          503  +  if {[wapp-param-exists control_run]} {
          504  +    # This is a "run test" command.
          505  +    set_test_array
          506  +    set ::G(state) "running"
          507  +  }
          508  +
          509  +  if {[wapp-param-exists control_stop]} {
          510  +    # A "STOP tests" command.
          511  +    set G(state) "stopped"
          512  +    set G(result) "Test halted by user"
          513  +    foreach j $G(test_array) {
          514  +      set name [dict get $j config]
          515  +      if { [info exists G(test.$name.channel)] } {
          516  +        close $G(test.$name.channel)
          517  +        unset G(test.$name.channel)
          518  +        slave_test_done $name 1
          519  +      }
          520  +    }
          521  +  }
          522  +
          523  +  if {[wapp-param-exists control_reset]} {
          524  +    # A "reset app" command.
          525  +    set G(state) "config"
          526  +    wapptest_init
          527  +  }
          528  +
          529  +  if {$::G(state) == "running"} {
          530  +    do_some_stuff
          531  +  }
          532  +  wapp-redirect /
          533  +}
          534  +
          535  +# URI: /style.css
          536  +#
          537  +# Return the stylesheet for the application main page.
          538  +#
          539  +proc wapp-page-style.css {} {
          540  +  wapp-subst {
          541  +
          542  +    /* The boxes with black borders use this class */
          543  +    .border {
          544  +      border: 3px groove #444444;
          545  +      padding: 1em;
          546  +      margin-top: 1em;
          547  +      margin-bottom: 1em;
          548  +    }
          549  +
          550  +    /* Float to the right (used for the Run/Stop/Reset button) */
          551  +    .right { float: right; }
          552  +
          553  +    /* Style for the large red warning at the top of the page */
          554  +    .warning {
          555  +      color: red;
          556  +      font-weight: bold;
          557  +    }
          558  +
          559  +    /* Styles used by cells in the test table */
          560  +    .padleft { padding-left: 5ex; }
          561  +    .nowrap  { white-space: nowrap; }
          562  +
          563  +    /* Styles for individual tests, depending on the outcome */
          564  +    .testwait    {              }
          565  +    .testrunning { color: blue  }
          566  +    .testdone    { color: green }
          567  +    .testfail    { color: red   }
          568  +  }
          569  +}
          570  +
          571  +# URI: /script/${state}.js
          572  +#
          573  +# The last part of this URI is always "config.js", "running.js" or 
          574  +# "stopped.js", depending on the state of the application. It returns
          575  +# the javascript part of the front-end for the requested state to the
          576  +# browser.
          577  +#
          578  +proc wapp-page-script {} {
          579  +  regexp {[^/]*$} [wapp-param REQUEST_URI] script
          580  +
          581  +  set tcl $::G(tcl)
          582  +  set keep $::G(keep)
          583  +  set msvc $::G(msvc)
          584  +  set debug $::G(debug)
          585  +  
          586  +  wapp-subst {
          587  +    var lElem = \["control_platform", "control_test", "control_msvc", 
          588  +        "control_jobs", "control_debug"
          589  +    \];
          590  +    lElem.forEach(function(e) {
          591  +      var elem = document.getElementById(e);
          592  +      elem.addEventListener("change", function() { control.submit() } );
          593  +    })
          594  +
          595  +    elem = document.getElementById("control_tcl");
          596  +    elem.value = "%string($tcl)"
          597  +
          598  +    elem = document.getElementById("control_keep");
          599  +    elem.checked = %string($keep);
          600  +
          601  +    elem = document.getElementById("control_msvc");
          602  +    elem.checked = %string($msvc);
          603  +
          604  +    elem = document.getElementById("control_debug");
          605  +    elem.checked = %string($debug);
          606  +  }
          607  +
          608  +  if {$script != "config.js"} {
          609  +    wapp-subst {
          610  +      var lElem = \["control_platform", "control_test", 
          611  +          "control_tcl", "control_keep", "control_msvc"
          612  +      \];
          613  +      lElem.forEach(function(e) {
          614  +        var elem = document.getElementById(e);
          615  +        elem.disabled = true;
          616  +      })
          617  +    }
          618  +  }
          619  +
          620  +  if {$script == "running.js"} {
          621  +    wapp-subst {
          622  +      function reload_tests() {
          623  +        fetch('tests')
          624  +          .then( data => data.text() )
          625  +          .then( data => {
          626  +            document.getElementById("tests").innerHTML = data;
          627  +          })
          628  +          .then( data => {
          629  +            if( document.getElementById("result") ){
          630  +              document.location = document.location;
          631  +            } else {
          632  +              setTimeout(reload_tests, 1000)
          633  +            }
          634  +          });
          635  +      }
          636  +
          637  +      setTimeout(reload_tests, 1000)
          638  +    }
          639  +  }
          640  +}
          641  +
          642  +# URI: /env
          643  +#
          644  +# This is for debugging only. Serves no other purpose.
          645  +#
          646  +proc wapp-page-env {} {
          647  +  wapp-allow-xorigin-params
          648  +  wapp-trim {
          649  +    <h1>Wapp Environment</h1>\n<pre>
          650  +    <pre>%html([wapp-debug-env])</pre>
          651  +  }
          652  +}
          653  +
          654  +# URI: /log/dirname/test.log
          655  +#
          656  +# This URI reads file "dirname/test.log" from disk, wraps it in a <pre>
          657  +# block, and returns it to the browser. Use for viewing log files.
          658  +#
          659  +proc wapp-page-log {} {
          660  +  set log [string range [wapp-param REQUEST_URI] 5 end]
          661  +  set fd [open $log]
          662  +  set data [read $fd]
          663  +  close $fd
          664  +  wapp-trim {
          665  +    <pre>
          666  +    %html($data)
          667  +    </pre>
          668  +  }
          669  +}
          670  +
          671  +wapptest_init
          672  +wapp-start $argv
          673  +