path: root/test/tester.tcl

#
# 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
}