initial commitHEADmaster

1 files changed, 1184 insertions, 0 deletions

diff --git a/test/tester.tcl b/test/tester.tcl
new file mode 100644
index 0000000..a720ec1
--- /dev/null
+++ b/test/tester.tcl
@@ -0,0 +1,1184 @@
+#
+# Copyright (c) 2006 D. Richard Hipp
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the Simplified BSD License (also
+# known as the "2-Clause License" or "FreeBSD License".)
+#
+# This program is distributed in the hope that it will be useful,
+# but without any warranty; without even the implied warranty of
+# merchantability or fitness for a particular purpose.
+#
+# Author contact information:
+#   drh@hwaci.com
+#   http://www.hwaci.com/drh/
+#
+############################################################################
+#
+# This is the main test script.  To run a regression test, do this:
+#
+#     tclsh ../test/tester.tcl ../bld/fossil
+#
+# Where ../test/tester.tcl is the name of this file and ../bld/fossil
+# is the name of the executable to be tested.
+#
+# To run a subset of tests (i.e. only one or more of the test/*.test
+# scripts), append the script base names as arguments:
+#
+#     tclsh ../test/tester.tcl ../bld/fossil <script-basename>...
+#
+
+# This testing system is a mess.  It was poorly designed to begin with
+# and has not been maintained.  It is difficult to debug.  It is completely
+# disabled for the time being.
+#
+# If somebody wants to volunteer to fix it, then great.  But without a
+# volunteer to do so, it is disabled.
+#
+puts Ok
+exit
+
+# We use some things introduced in 8.6 such as lmap.  auto.def should
+# have found us a suitable Tcl installation.
+package require Tcl 8.6-
+
+set testfiledir [file normalize [file dirname [info script]]]
+set testrundir [pwd]
+set testdir [file normalize [file dirname $argv0]]
+set fossilexe [file normalize [lindex $argv 0]]
+set is_windows [expr {$::tcl_platform(platform) eq "windows"}]
+set is_cygwin [regexp {^CYGWIN} $::tcl_platform(os)]
+
+if {$::is_windows} {
+  if {[string length [file extension $fossilexe]] == 0} {
+    append fossilexe .exe
+  }
+  set outside_fossil_repo [expr ![file exists "$::testfiledir\\..\\_FOSSIL_"]]
+} else {
+  set outside_fossil_repo [expr ![file exists "$::testfiledir/../.fslckout"]]
+}
+
+catch {exec $::fossilexe changes --changed} res
+set dirty_ckout [string length $res]
+
+set argv [lrange $argv 1 end]
+
+set i [lsearch $argv -keep]
+if {$i>=0} {
+  set KEEP 1
+  set argv [lreplace $argv $i $i]
+} else {
+  set KEEP 0
+}
+
+set i [lsearch $argv -halt]
+if {$i>=0} {
+  set HALT 1
+  set argv [lreplace $argv $i $i]
+} else {
+  set HALT 0
+}
+
+set i [lsearch $argv -prot]
+if {$i>=0} {
+  set PROT 1
+  set argv [lreplace $argv $i $i]
+} else {
+  set PROT 0
+}
+
+set i [lsearch $argv -verbose]
+if {$i>=0} {
+  set VERBOSE 1
+  set argv [lreplace $argv $i $i]
+} else {
+  set VERBOSE 0
+}
+
+set i [lsearch $argv -quiet]
+if {$i>=0} {
+  set QUIET 1
+  set argv [lreplace $argv $i $i]
+} else {
+  set QUIET 0
+}
+
+set i [lsearch $argv -strict]
+if {$i>=0} {
+  set STRICT 1
+  set argv [lreplace $argv $i $i]
+} else {
+  set STRICT 0
+}
+
+if {[llength $argv]==0} {
+  foreach f [lsort [glob $testdir/*.test]] {
+    set base [file root [file tail $f]]
+    lappend argv $base
+  }
+}
+
+# start protocol
+#
+proc protInit {cmd} {
+  if {$::PROT} {
+    set out [open [file join $::testrundir prot] w]
+    fconfigure $out -translation platform
+    puts $out "starting tests with: $cmd"
+    close $out
+  }
+}
+
+# write protocol
+#
+proc protOut {msg {noQuiet 0}} {
+  if {$noQuiet || !$::QUIET} {
+    puts stdout $msg
+  }
+  if {$::PROT} {
+    set out [open [file join $::testrundir prot] a]
+    fconfigure $out -translation platform
+    puts $out $msg
+    close $out
+  }
+}
+
+# write a dict with just enough formatting
+# to make it human readable
+#
+proc protOutDict {dict {pattern *}} {
+   set longest [tcl::mathfunc::max 0 {*}[lmap key [dict keys $dict $pattern] {string length $key}]]
+   dict for {key value} $dict {
+      protOut [format "%-${longest}s = %s" $key $value]
+   }
+}
+
+
+# Run the Fossil program with the specified arguments.
+#
+# Consults the VERBOSE global variable to determine if
+# diagnostics should be emitted when no error is seen.
+# Sets the CODE and RESULT global variables for use in
+# test expressions.
+#
+proc fossil {args} {
+  return [uplevel 1 fossil_maybe_answer [list ""] $args]
+}
+
+# Run the Fossil program with the specified arguments
+# and possibly answer the first prompt, if any.
+#
+# Consults the VERBOSE global variable to determine if
+# diagnostics should be emitted when no error is seen.
+# Sets the CODE and RESULT global variables for use in
+# test expressions.
+#
+proc fossil_maybe_answer {answer args} {
+  global fossilexe
+  set cmd $fossilexe
+  set expectError 0
+  set index [lsearch -exact $args -expectError]
+  if {$index != -1} {
+    set expectError 1
+    set args [lreplace $args $index $index]
+  }
+  set keepNewline 0
+  set index [lsearch -exact $args -keepNewline]
+  if {$index != -1} {
+    set keepNewline 1
+    set args [lreplace $args $index $index]
+  }
+  set whatIf 0
+  set index [lsearch -exact $args -whatIf]
+  if {$index != -1} {
+    set whatIf 1
+    set args [lreplace $args $index $index]
+  }
+  foreach a $args {
+    lappend cmd $a
+  }
+  protOut $cmd
+
+  flush stdout
+  if {$whatIf} {
+    protOut [pwd]; protOut $answer
+    set result WHAT-IF-MODE; set rc 42
+  } else {
+    if {[string length $answer] > 0} {
+      protOut $answer
+      set prompt_file [file join $::tempPath fossil_prompt_answer]
+      write_file $prompt_file $answer\n
+      set execCmd [list eval exec]
+      if {$keepNewline} {lappend execCmd -keepnewline}
+      lappend execCmd $cmd <$prompt_file
+      set rc [catch $execCmd result]
+      file delete $prompt_file
+    } else {
+      set execCmd [list eval exec]
+      if {$keepNewline} {lappend execCmd -keepnewline}
+      lappend execCmd $cmd
+      set rc [catch $execCmd result]
+    }
+  }
+  set ab(str) {child process exited abnormally}
+  set ab(len) [string length $ab(str)]
+  set ab(off) [expr {$ab(len) - 1}]
+  if {$rc && $expectError && \
+      [string range $result end-$ab(off) end] eq $ab(str)} {
+    set result [string range $result 0 end-$ab(len)]
+  }
+  global RESULT CODE
+  set CODE $rc
+  if {!$whatIf} {
+    if {($rc && !$expectError) || (!$rc && $expectError)} {
+      protOut "ERROR ($rc): $result" 1
+    } elseif {$::VERBOSE} {
+      protOut "RESULT ($rc): $result"
+    }
+  }
+  set RESULT $result
+}
+
+# Read a file into memory.
+#
+proc read_file {filename} {
+  set in [open $filename r]
+  fconfigure $in -translation binary
+  set txt [read $in [file size $filename]]
+  close $in
+  return $txt
+}
+
+# Write a file to disk
+#
+proc write_file {filename txt} {
+  set out [open $filename w]
+  fconfigure $out -translation binary
+  puts -nonewline $out $txt
+  close $out
+}
+proc write_file_indented {filename txt} {
+  write_file $filename [string trim [string map [list "\n  " \n] $txt]]\n
+}
+
+# Returns the list of all supported versionable settings.
+#
+proc get_versionable_settings {} {
+  #
+  # TODO: If the list of supported versionable settings in "db.c" is modified,
+  #       this list (and procedure) most likely needs to be modified as well.
+  #
+  set result [list \
+      binary-glob \
+      clean-glob \
+      crlf-glob \
+      crnl-glob \
+      dotfiles \
+      empty-dirs \
+      encoding-glob \
+      ignore-glob \
+      keep-glob \
+      manifest]
+
+  return [lsort -dictionary $result]
+}
+
+# Returns the list of all supported settings.
+#
+proc get_all_settings {} {
+  #
+  # TODO: If the list of supported settings in "db.c" is modified, this list
+  #       (and procedure) most likely needs to be modified as well.
+  #
+  set result [list \
+      access-log \
+      admin-log \
+      allow-symlinks \
+      auto-captcha \
+      auto-hyperlink \
+      auto-hyperlink-delay \
+      auto-hyperlink-mouseover \
+      auto-shun \
+      autosync \
+      autosync-tries \
+      backoffice-disable \
+      backoffice-logfile \
+      backoffice-nodelay \
+      binary-glob \
+      case-sensitive \
+      chat-alert-sound \
+      chat-initial-history \
+      chat-inline-images \
+      chat-keep-count \
+      chat-keep-days \
+      chat-poll-timeout \
+      chat-timeline-user \
+      clean-glob \
+      clearsign \
+      comment-format \
+      crlf-glob \
+      crnl-glob \
+      default-csp \
+      default-perms \
+      default-skin \
+      diff-binary \
+      diff-command \
+      dont-commit \
+      dont-push \
+      dotfiles \
+      editor \
+      email-admin \
+      email-listid \
+      email-renew-interval \
+      email-self \
+      email-send-command \
+      email-send-db \
+      email-send-dir \
+      email-send-method \
+      email-send-relayhost \
+      email-subname \
+      email-url \
+      empty-dirs \
+      encoding-glob \
+      exec-rel-paths \
+      fileedit-glob \
+      forbid-delta-manifests \
+      forum-close-policy \
+      forum-title \
+      gdiff-command \
+      gmerge-command \
+      hash-digits \
+      hooks \
+      http-port \
+      https-login \
+      ignore-glob \
+      keep-glob \
+      large-file-size \
+      localauth \
+      lock-timeout \
+      main-branch \
+      mainmenu \
+      manifest \
+      max-cache-entry \
+      max-loadavg \
+      max-upload \
+      mimetypes \
+      mtime-changes \
+      mv-rm-files \
+      pgp-command \
+      preferred-diff-type \
+      proxy \
+      raw-bgcolor \
+      redirect-to-https \
+      relative-paths \
+      repo-cksum \
+      repolist-skin \
+      robot-restrict \
+      robots-txt \
+      safe-html \
+      self-pw-reset \
+      self-register \
+      sitemap-extra \
+      ssh-command \
+      ssl-ca-location \
+      ssl-identity \
+      tclsh \
+      th1-setup \
+      th1-uri-regexp \
+      ticket-default-report \
+      timeline-hard-newlines \
+      timeline-plaintext \
+      timeline-truncate-at-blank \
+      timeline-tslink-info \
+      timeline-utc \
+      user-color-map \
+      verify-comments \
+      uv-sync \
+      vuln-report \
+      web-browser]
+
+  fossil test-th-eval "hasfeature legacyMvRm"
+
+  if {[normalize_result] eq "1"} {
+    lappend result mv-rm-files
+  }
+
+  fossil test-th-eval "hasfeature tcl"
+
+  if {[normalize_result] eq "1"} {
+    lappend result tcl tcl-setup
+  }
+
+  fossil test-th-eval "hasfeature th1Docs"
+
+  if {[normalize_result] eq "1"} {
+    lappend result th1-docs
+  }
+
+  fossil test-th-eval "hasfeature th1Hooks"
+
+  if {[normalize_result] eq "1"} {
+    lappend result th1-hooks
+  }
+
+  return [lsort -dictionary $result]
+}
+
+# Return true if two files are the same
+#
+proc same_file {a b} {
+  set x [read_file $a]
+  regsub -all { +\n} $x \n x
+  set y [read_file $b]
+  regsub -all { +\n} $y \n y
+  if {$x == $y} {
+    return 1
+  } else {
+    if {$::VERBOSE} {
+      protOut "NOT_SAME_FILE($a): \{\n$x\n\}"
+      protOut "NOT_SAME_FILE($b): \{\n$y\n\}"
+    }
+    return 0
+  }
+}
+
+# Return true if two strings refer to the
+# same uuid. That is, the shorter is a prefix
+# of the longer.
+#
+proc same_uuid {a b} {
+  set na [string length $a]
+  set nb [string length $b]
+  if {$na == $nb} {
+    return [expr {$a eq $b}]
+  }
+  if {$na < $nb} {
+    return [string match "$a*" $b]
+  }
+  return [string match "$b*" $a]
+}
+
+# Return a prefix of a uuid, defaulting to 10 chars.
+#
+proc short_uuid {uuid {len 10}} {
+  string range $uuid 0 $len-1
+}
+
+
+proc require_no_open_checkout {} {
+  if {[info exists ::env(FOSSIL_TEST_DANGEROUS_IGNORE_OPEN_CHECKOUT)] && \
+      $::env(FOSSIL_TEST_DANGEROUS_IGNORE_OPEN_CHECKOUT) eq "YES_DO_IT"} {
+    return
+  }
+  catch {exec $::fossilexe info} res
+  if {[regexp {local-root:} $res]} {
+    global skipped_tests testfile
+    lappend skipped_tests $testfile
+    set projectName <unknown>
+    set localRoot <unknown>
+    regexp -line -- {^project-name: (.*)$} $res dummy projectName
+    set projectName [string trim $projectName]
+    regexp -line -- {^local-root: (.*)$} $res dummy localRoot
+    set localRoot [string trim $localRoot]
+    error "Detected an open checkout of project \"$projectName\",\
+rooted at \"$localRoot\", testing halted."
+  }
+}
+
+proc get_script_or_fail {} {
+  set fileName [file normalize [info script]]
+  if {[string length $fileName] == 0 || ![file exists $fileName]} {
+    error "Failed to obtain the file name of the test being run."
+  }
+  return $fileName
+}
+
+proc robust_delete { path {force ""} } {
+  set error "unknown error"
+  for {set try 0} {$try < 10} {incr try} {
+    if {$force eq "YES_DO_IT"} {
+      if {[catch {file delete -force $path} error] == 0} {
+        return
+      }
+    } else {
+      if {[catch {file delete $path} error] == 0} {
+        return
+      }
+    }
+    after [expr {$try * 100}]
+  }
+  error "Could not delete \"$path\", error: $error"
+}
+
+proc test_cleanup_then_return {} {
+  global skipped_tests testfile
+  lappend skipped_tests $testfile
+  uplevel 1 [list test_cleanup]
+  return -code return
+}
+
+proc test_cleanup {} {
+  if {$::KEEP} {
+      # To avoid errors with require_no_open_checkout, cd out of here.
+      if {[info exists ::tempSavedPwd]} {cd $::tempSavedPwd; unset ::tempSavedPwd}
+      return
+  }
+  if {![info exists ::tempRepoPath]} {return}
+  if {![file exists $::tempRepoPath]} {return}
+  if {![file isdirectory $::tempRepoPath]} {return}
+  set tempPathEnd [expr {[string length $::tempPath] - 1}]
+  if {[string length $::tempPath] == 0 || \
+      [string range $::tempRepoPath 0 $tempPathEnd] ne $::tempPath} {
+    error "Temporary repository path has wrong parent during cleanup."
+  }
+  if {[info exists ::tempSavedPwd]} {cd $::tempSavedPwd; unset ::tempSavedPwd}
+  # First, attempt to delete the specific temporary repository directories
+  # for this test file.
+  set scriptName [file tail [get_script_or_fail]]
+  foreach repoSeed $::tempRepoSeeds {
+    set repoPath [file join $::tempRepoPath $repoSeed $scriptName]
+    robust_delete $repoPath YES_DO_IT; # FORCE, arbitrary children.
+    set seedPath [file join $::tempRepoPath $repoSeed]
+    robust_delete $seedPath; # NO FORCE.
+  }
+  # Next, attempt to gracefully delete the temporary repository directory
+  # for this process.
+  robust_delete $::tempRepoPath
+  # Finally, attempt to gracefully delete the temporary home directory,
+  # unless forbidden by external forces.
+  if {![info exists ::tempKeepHome]} {delete_temporary_home}
+}
+
+proc delete_temporary_home {} {
+  if {$::KEEP} {return}; # All cleanup disabled?
+  if {$::is_windows || $::is_cygwin} {
+    robust_delete [file join $::tempHomePath _fossil]
+  } else {
+    robust_delete [file join $::tempHomePath .fossil]
+  }
+  robust_delete $::tempHomePath
+}
+
+proc is_home_elsewhere {} {
+  return [expr {[info exists ::env(FOSSIL_HOME)] && \
+      $::env(FOSSIL_HOME) eq $::tempHomePath}]
+}
+
+proc set_home_to_elsewhere {} {
+  #
+  # Fossil will write data on $HOME (or $FOSSIL_HOME).  We need not
+  # to clutter the real $HOME (or $FOSSIL_HOME) of the test caller.
+  #
+  if {[is_home_elsewhere]} {return}
+  set ::env(FOSSIL_HOME) $::tempHomePath
+}
+
+#
+# Create and open a new Fossil repository and clean the checkout
+#
+proc test_setup {{filename ".rep.fossil"}} {
+  set_home_to_elsewhere
+  if {![info exists ::tempRepoPath]} {
+    set ::tempRepoPath [file join $::tempPath repo_[pid]]
+  }
+  set repoSeed [appendArgs [string trim [clock seconds] -] _ [getSeqNo]]
+  lappend ::tempRepoSeeds $repoSeed
+  set repoPath [file join \
+      $::tempRepoPath $repoSeed [file tail [get_script_or_fail]]]
+  if {[catch {
+    file mkdir $repoPath
+  } error] != 0} {
+    error "Could not make directory \"$repoPath\",\
+please set TEMP variable in environment, error: $error"
+  }
+  if {![info exists ::tempSavedPwd]} {set ::tempSavedPwd [pwd]}; cd $repoPath
+  if {[string length $filename] > 0} {
+    exec $::fossilexe new $filename
+    exec $::fossilexe open $filename
+    exec $::fossilexe set mtime-changes off
+  }
+  return $repoPath
+}
+
+# This procedure only returns non-zero if the Tcl integration feature was
+# enabled at compile-time and is now enabled at runtime.
+proc is_tcl_usable_by_fossil {} {
+  fossil test-th-eval "hasfeature tcl"
+  if {[normalize_result] ne "1"} {return 0}
+  fossil test-th-eval "setting tcl"
+  if {[normalize_result] eq "1"} {return 1}
+  fossil test-th-eval --open-config "setting tcl"
+  if {[normalize_result] eq "1"} {return 1}
+  return [info exists ::env(TH1_ENABLE_TCL)]
+}
+
+# This procedure only returns non-zero if the TH1 hooks feature was enabled
+# at compile-time and is now enabled at runtime.
+proc are_th1_hooks_usable_by_fossil {} {
+  fossil test-th-eval "hasfeature th1Hooks"
+  if {[normalize_result] ne "1"} {return 0}
+  fossil test-th-eval "setting th1-hooks"
+  if {[normalize_result] eq "1"} {return 1}
+  fossil test-th-eval --open-config "setting th1-hooks"
+  if {[normalize_result] eq "1"} {return 1}
+  return [info exists ::env(TH1_ENABLE_HOOKS)]
+}
+
+# Run the given command script inside the Fossil source repo checkout.
+#
+# Callers of this function must ensure two things:
+#
+# 1. This test run is in fact being done from within a Fossil repo
+#    checkout directory.  If you are unsure, test $::outside_fossil_repo
+#    or call one of the test_* wrappers below which do that for you.
+#
+#    As a rule, you should not be calling this function directly!
+#
+# 2. This test run is being done from a repo checkout directory that
+#    doesn't have any uncommitted changes.  If it does, that affects the
+#    output of any test based on the output of "fossil status",
+#    "... diff", etc., which is likely to make the test appear to fail.
+#    If you must call this function directly, test $::dirty_ckout and
+#    skip the call if it's true.  The test_* wrappers do this for you.
+#
+# 3. The test does NOT modify the Fossil checkout tree in any way.
+proc run_in_checkout { script {dir ""} } {
+  if {[string length $dir] == 0} {set dir $::testfiledir}
+  set savedPwd [pwd]; cd $dir
+  set code [catch {
+    uplevel 1 $script
+  } result]
+  cd $savedPwd; unset savedPwd
+  return -code $code $result
+}
+
+# Wrapper for the above function pair.  The tscript parameter is an
+# optional post-run test script.  Some callers choose instead to put
+# the tests inline with the rscript commands.
+#
+# Be sure to adhere to the requirements of run_in_checkout!
+proc test_block_in_checkout { name rscript {tscript ""} } {
+  if {$::outside_fossil_repo || $::dirty_ckout} {
+    set $::CODE 0
+    set $::RESULT ""
+  } else {
+    uplevel 1 [list run_in_checkout $rscript]
+    if {[string length $tscript] == 0} {
+      return ""
+    } else {
+      set code [catch {
+        uplevel 1 $tscript
+      } result]
+      return -code $code $result
+    }
+  }
+}
+
+# Single-test wrapper for the above.
+proc test_in_checkout { name rscript tscript } {
+  return test_block_in_checkout name rscript {
+    test $name $tscript
+  }
+}
+
+# Normalize file status lists (like those returned by 'fossil changes')
+# so they can be compared using simple string comparison
+#
+proc normalize_status_list {list} {
+  set normalized [list]
+  set matches [regexp -all -inline -line {^\s*([A-Z_]+:?)\x20+(\S.*)$} $list]
+  foreach {_ status file} $matches {
+    lappend normalized [list $status [string trim $file]]
+  }
+  set normalized [lsort -index 1 $normalized]
+  return $normalized
+}
+
+# Perform a test comparing two status lists
+#
+proc test_status_list {name result expected {constraints ""}} {
+  set expected [normalize_status_list $expected]
+  set result [normalize_status_list $result]
+  if {$result eq $expected} {
+    test $name 1 $constraints
+  } else {
+    protOut "  Expected:\n    [join $expected "\n    "]" 1
+    protOut "  Got:\n    [join $result "\n    "]" 1
+    test $name 0 $constraints
+  }
+}
+
+# Perform a test on the contents of a file
+#
+proc test_file_contents {name path expected {constraints ""}} {
+  if {[file exists $path]} {
+    set result [read_file $path]
+    set passed [expr {$result eq $expected}]
+    if {!$passed} {
+      set expectedLines [split $expected "\n"]
+      set resultLines [split $result "\n"]
+      protOut "  Expected:\n    [join $expectedLines "\n    "]" 1
+      protOut "  Got:\n    [join $resultLines "\n    "]" 1
+    }
+  } else {
+    set passed 0
+    protOut "  File does not exist: $path" 1
+  }
+  test $name $passed $constraints
+}
+
+# Append all arguments into a single value and then returns it.
+#
+proc appendArgs {args} {
+  eval append result $args
+}
+
+# Returns the value of the specified environment variable -OR- any empty
+# string if it does not exist.
+#
+proc getEnvironmentVariable { name } {
+  return [expr {[info exists ::env($name)] ? $::env($name) : ""}]
+}
+
+# Returns a usable temporary directory -OR- fails the testing process.
+#
+proc getTemporaryPath {} {
+  #
+  # NOTE: Build the list of "temporary directory" environment variables
+  #       to check, including all reasonable "cases" of the environment
+  #       variable names.
+  #
+  set names [list]
+
+  #
+  # TODO: Add more here, if necessary.
+  #
+  foreach name [list FOSSIL_TEST_TEMP FOSSIL_TEMP TEMP TMP] {
+    lappend names [string toupper $name] [string tolower $name] \
+        [string totitle $name]
+  }
+
+  #
+  # NOTE: Check if we can use any of the environment variables.
+  #
+  foreach name $names {
+    set value [getEnvironmentVariable $name]
+
+    if {[string length $value] > 0} {
+      set value [file normalize $value]
+
+      if {[file exists $value] && [file isdirectory $value]} {
+        return $value
+      }
+    }
+  }
+
+  #
+  # NOTE: On non-Windows systems, fallback to /tmp if it is usable.
+  #
+  if {!$::is_windows} {
+    set value /tmp
+
+    if {[file exists $value] && [file isdirectory $value]} {
+      return $value
+    }
+  }
+
+  #
+  # NOTE: There must be a usable temporary directory to continue testing.
+  #
+  error "Cannot find a usable temporary directory, testing halted."
+}
+
+# Return the name of the versioned settings file containing the TH1
+# setup script.
+#
+proc getTh1SetupFileName {} {
+  #
+  # NOTE: This uses the "testdir" global variable provided by the
+  #       test suite; alternatively, the root of the source tree
+  #       could be obtained directly from Fossil.
+  #
+  return [file normalize [file join .fossil-settings th1-setup]]
+}
+
+# Return the saved name of the versioned settings file containing
+# the TH1 setup script.
+#
+proc getSavedTh1SetupFileName {} {
+  return [appendArgs [getTh1SetupFileName] . [pid]]
+}
+
+# Sets the TH1 setup script to the one provided.  Prior to calling
+# this, the [saveTh1SetupFile] procedure should be called in order to
+# preserve the existing TH1 setup script.  Prior to completing the test,
+# the [restoreTh1SetupFile] procedure should be called to restore the
+# original TH1 setup script.
+#
+proc writeTh1SetupFile { data } {
+  set fileName [getTh1SetupFileName]
+  file mkdir [file dirname $fileName]
+  return [write_file $fileName $data]
+}
+
+# Saves the TH1 setup script file by renaming it, based on the current
+# process ID.
+#
+proc saveTh1SetupFile {} {
+  set oldFileName [getTh1SetupFileName]
+  if {[file exists $oldFileName]} {
+    set newFileName [getSavedTh1SetupFileName]
+    catch {file delete $newFileName}
+    file rename $oldFileName $newFileName
+  }
+}
+
+# Restores the original TH1 setup script file by renaming it back, based
+# on the current process ID.
+#
+proc restoreTh1SetupFile {} {
+  set oldFileName [getSavedTh1SetupFileName]
+  set newFileName [getTh1SetupFileName]
+  if {[file exists $oldFileName]} {
+    catch {file delete $newFileName}
+    file rename $oldFileName $newFileName
+  } else {
+    #
+    # NOTE: There was no TH1 setup script file, delete the test one.
+    #
+    file delete $newFileName
+  }
+}
+
+# Perform a test
+#
+set test_count 0
+proc test {name expr {constraints ""}} {
+  global bad_test ignored_test test_count RESULT
+  incr test_count
+  set knownBug [expr {"knownBug" in $constraints}]
+  set r [uplevel 1 [list expr $expr]]
+  if {$r} {
+    if {$knownBug && !$::STRICT} {
+      protOut "test $name OK (knownBug)?"
+    } else {
+      protOut "test $name OK"
+    }
+  } else {
+    if {$knownBug && !$::STRICT} {
+      protOut "test $name FAILED (knownBug)!" 1
+      lappend ignored_test $name
+    } else {
+      protOut "test $name FAILED!" 1
+      if {$::QUIET} {protOut "RESULT: $RESULT" 1}
+      lappend bad_test $name
+      if {$::HALT} {exit 1}
+    }
+  }
+}
+set bad_test {}
+set ignored_test {}
+set skipped_tests {}
+
+# Return a random string N characters long.
+#
+set vocabulary 01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+append vocabulary "       ()*^!.eeeeeeeeaaaaattiioo   "
+set nvocabulary [string length $vocabulary]
+proc rand_str {N} {
+  global vocabulary nvocabulary
+  set out {}
+  while {$N>0} {
+    incr N -1
+    set i [expr {int(rand()*$nvocabulary)}]
+    append out [string index $vocabulary $i]
+  }
+  return $out
+}
+
+# Make random changes to a file.
+#
+# The file is divided into blocks of $blocksize lines each.  The first
+# block is number 0.  Changes are only made within blocks where
+# the block number divided by $count has a remainder of $index.
+#
+# For any given line that mets the block count criteria, the probably
+# of a change is $prob
+#
+# Changes do not add or remove newlines
+#
+proc random_changes {body blocksize count index prob} {
+  set out {}
+  set blockno 0
+  set lineno -1
+  foreach line [split $body \n] {
+    incr lineno
+    if {$lineno==$blocksize} {
+      incr blockno
+      set lineno 0
+    }
+    if {$blockno%$count==$index && rand()<$prob} {
+      set n [string length $line]
+      if {$n>5 && rand()<0.5} {
+        # delete part of the line
+        set n [expr {int(rand()*$n)}]
+        set i [expr {int(rand()*$n)}]
+        set k [expr {$i+$n}]
+        set line [string range $line 0 $i][string range $line $k end]
+      } else {
+        # insert something into the line
+        set stuff [rand_str [expr {int(rand()*($n-5))-1}]]
+        set i [expr {int(rand()*$n)}]
+        set ip1 [expr {$i+1}]
+        set line [string range $line 0 $i]$stuff[string range $line $ip1 end]
+      }
+    }
+    append out \n$line
+  }
+  return [string range $out 1 end]
+}
+
+# This procedure executes the "fossil server" command.  The return value
+# is a list comprised of the new process identifier and the port on which
+# the server started.  The varName argument refers to a variable
+# where the "stop argument" is to be stored.  This value must eventually be
+# passed to the [test_stop_server] procedure.
+proc test_start_server { repository {varName ""} } {
+  global fossilexe tempPath
+  set command [list exec $fossilexe server --localhost]
+  if {[string length $varName] > 0} {
+    upvar 1 $varName stopArg
+  }
+  if {$::is_windows} {
+    set stopArg [file join [getTemporaryPath] [appendArgs \
+        [string trim [clock seconds] -] _ [getSeqNo] .stopper]]
+    lappend command --stopper $stopArg
+  }
+  set outFileName [file join $tempPath [appendArgs \
+      fossil_server_ [string trim [clock seconds] -] _ \
+      [getSeqNo]]].out
+  lappend command $repository >&$outFileName &
+  set pid [eval $command]
+  if {!$::is_windows} {
+    set stopArg $pid
+  }
+  after 1000; # output might not be there yet
+  set output [read_file $outFileName]
+  if {![regexp {Listening.*TCP port (\d+)} $output dummy port]} {
+    puts stdout "Could not detect Fossil server port, using default..."
+    set port 8080; # return the default port just in case
+  }
+  return [list $pid $port $outFileName]
+}
+
+# This procedure stops a Fossil server instance that was previously started
+# by the [test_start_server] procedure.  The value of the "stop argument"
+# will vary by platform as will the exact method used to stop the server.
+# The fileName argument is the name of a temporary output file to delete.
+proc test_stop_server { stopArg pid fileName } {
+  if {$::is_windows} {
+    #
+    # NOTE: On Windows, the "stop argument" must be the name of a file
+    #       that does NOT already exist.
+    #
+    if {[string length $stopArg] > 0 && \
+        ![file exists $stopArg] && \
+        [catch {write_file $stopArg [clock seconds]}] == 0} {
+      while {1} {
+        if {[catch {
+          #
+          # NOTE: Using the TaskList utility requires Windows XP or
+          #       later.
+          #
+          exec tasklist.exe /FI "PID eq $pid"
+        } result] != 0 || ![regexp -- " $pid " $result]} {
+          break
+        }
+        after 1000; # wait a bit...
+      }
+      file delete $stopArg
+      if {[string length $fileName] > 0} {
+        file delete $fileName
+      }
+      return true
+    }
+  } else {
+    #
+    # NOTE: On Unix, the "stop argument" must be an integer identifier
+    #       that refers to an existing process.
+    #
+    if {[regexp {^(?:-)?\d+$} $stopArg] && \
+        [catch {exec kill -TERM $stopArg}] == 0} {
+      while {1} {
+        if {[catch {
+          #
+          # TODO: Is this portable to all the supported variants of
+          #       Unix?  It should be, it's POSIX.
+          #
+          exec ps -p $pid
+        } result] != 0 || ![regexp -- "(?:^$pid| $pid) " $result]} {
+          break
+        }
+        after 1000; # wait a bit...
+      }
+      if {[string length $fileName] > 0} {
+        file delete $fileName
+      }
+      return true
+    }
+  }
+  return false
+}
+
+# Executes the "fossil http" command.  The entire content of the HTTP request
+# is read from the data file name, with [subst] being performed on it prior to
+# submission.  Temporary input and output files are created and deleted.  The
+# result will be the contents of the temoprary output file.
+proc test_fossil_http { repository dataFileName url } {
+  set suffix [appendArgs [pid] - [getSeqNo] - [clock seconds] .txt]
+  set inFileName [file join $::tempPath [appendArgs test-http-in- $suffix]]
+  set outFileName [file join $::tempPath [appendArgs test-http-out- $suffix]]
+  set data [subst [read_file $dataFileName]]
+
+  write_file $inFileName $data
+
+  fossil http --in $inFileName --out $outFileName --ipaddr 127.0.0.1 \
+      $repository --localauth --th-trace -expectError
+
+  set result [expr {[file exists $outFileName] ? [read_file $outFileName] : ""}]
+
+  if {1} {
+    catch {file delete $inFileName}
+    catch {file delete $outFileName}
+  }
+
+  return $result
+}
+
+# obtains and increments a "sequence number" for this test run.
+proc getSeqNo {} {
+  upvar #0 seqNo seqNo
+  if {![info exists seqNo]} {
+    set seqNo 0
+  }
+  return [incr seqNo]
+}
+
+# fixup the whitespace in the result to make it easier to compare.
+proc normalize_result {} {
+  return [string map [list \r\n \n] [string trim $::RESULT]]
+}
+
+# fixup the line-endings in the result to make it easier to compare.
+proc normalize_result_no_trim {} {
+  return [string map [list \r\n \n] $::RESULT]
+}
+
+# returns the first line of the normalized result.
+proc first_data_line {} {
+  return [lindex [split [normalize_result] \n] 0]
+}
+
+# returns the second line of the normalized result.
+proc second_data_line {} {
+  return [lindex [split [normalize_result] \n] 1]
+}
+
+# returns the third line of the normalized result.
+proc third_data_line {} {
+  return [lindex [split [normalize_result] \n] 2]
+}
+
+# returns the last line of the normalized result.
+proc last_data_line {} {
+  return [lindex [split [normalize_result] \n] end]
+}
+
+# returns the second to last line of the normalized result.
+proc next_to_last_data_line {} {
+  return [lindex [split [normalize_result] \n] end-1]
+}
+
+# returns the third to last line of the normalized result.
+proc third_to_last_data_line {} {
+  return [lindex [split [normalize_result] \n] end-2]
+}
+
+set tempPath [getTemporaryPath]
+
+if {$is_windows} {
+  set tempPath [string map [list \\ /] $tempPath]
+}
+
+if {[catch {
+  set tempFile [file join $tempPath temporary.txt]
+  write_file $tempFile [clock seconds]; file delete $tempFile
+} error] != 0} {
+  error "Could not write file \"$tempFile\" in directory \"$tempPath\",\
+please set TEMP variable in environment, error: $error"
+}
+
+set tempHomePath [file join $tempPath home_[pid]]
+
+# Close stdin to avoid errors on wrapped text for narrow terminals.
+# Closing stdin means that terminal detection returns 0 width, in turn
+# causing the relvant strings to be printed on a single line.
+# However, closing stdin makes file descriptor 0 avaailable on some systems
+# and/or TCL implementations, which triggers fossil to complain about opening
+# databases using fd 0. Avoid this by opening the script, consuming fd 0.
+close stdin
+set possibly_fd0 [open [info script] r]
+
+if {[catch {
+  file mkdir $tempHomePath
+} error] != 0} {
+  error "Could not make directory \"$tempHomePath\",\
+please set TEMP variable in environment, error: $error"
+}
+
+
+protInit $fossilexe
+set ::tempKeepHome 1
+
+# Start in tempHomePath to help avoid errors with require_no_open_checkout
+set startPwd [pwd]
+cd $tempHomePath
+
+foreach testfile $argv {
+  protOut "***** $testfile ******"
+  if { [catch {source $testdir/$testfile.test} testerror testopts] } {
+    test test-framework-$testfile 0
+    protOut "!!!!! $testfile: $testerror"
+    protOutDict $testopts"
+  } else {
+    test test-framework-$testfile 1
+  }
+  protOut "***** End of $testfile: [llength $bad_test] errors so far ******"
+}
+cd $startPwd
+unset ::tempKeepHome; delete_temporary_home
+
+# Clean up the file descriptor
+close $possibly_fd0
+
+set nErr [llength $bad_test]
+if {$nErr>0 || !$::QUIET} {
+  protOut "***** Final results: $nErr errors out of $test_count tests" 1
+}
+if {$nErr>0} {
+  protOut "***** Considered failures: $bad_test" 1
+}
+set nErr [llength $ignored_test]
+if {$nErr>0 || !$::QUIET} {
+  protOut "***** Ignored results: $nErr ignored errors out of $test_count tests" 1
+}
+if {$nErr>0} {
+  protOut "***** Ignored failures: $ignored_test" 1
+}
+set nSkipped [llength $skipped_tests]
+if {$nSkipped>0} {
+  protOut "***** Skipped tests: $skipped_tests" 1
+}
+if {$bad_test>0} {
+  exit 1
+}