1#
2# Copyright (c) 2006 D. Richard Hipp
3#
4# This program is free software; you can redistribute it and/or
5# modify it under the terms of the Simplified BSD License (also
6# known as the "2-Clause License" or "FreeBSD License".)
7#
8# This program is distributed in the hope that it will be useful,
9# but without any warranty; without even the implied warranty of
10# merchantability or fitness for a particular purpose.
11#
12# Author contact information:
13#   drh@hwaci.com
14#   http://www.hwaci.com/drh/
15#
16############################################################################
17#
18# This is the main test script.  To run a regression test, do this:
19#
20#     tclsh ../test/tester.tcl ../bld/fossil
21#
22# Where ../test/tester.tcl is the name of this file and ../bld/fossil
23# is the name of the executable to be tested.
24#
25
26# We use some things introduced in 8.6 such as lmap.  auto.def should
27# have found us a suitable Tcl installation.
28package require Tcl 8.6
29
30set testfiledir [file normalize [file dirname [info script]]]
31set testrundir [pwd]
32set testdir [file normalize [file dirname $argv0]]
33set fossilexe [file normalize [lindex $argv 0]]
34set is_windows [expr {$::tcl_platform(platform) eq "windows"}]
35
36if {$::is_windows} {
37  if {[string length [file extension $fossilexe]] == 0} {
38    append fossilexe .exe
39  }
40  set outside_fossil_repo [expr ![file exists "$::testfiledir\\..\\_FOSSIL_"]]
41} else {
42  set outside_fossil_repo [expr ![file exists "$::testfiledir/../.fslckout"]]
43}
44
45catch {exec $::fossilexe changes --changed} res
46set dirty_ckout [string length $res]
47
48set argv [lrange $argv 1 end]
49
50set i [lsearch $argv -keep]
51if {$i>=0} {
52  set KEEP 1
53  set argv [lreplace $argv $i $i]
54} else {
55  set KEEP 0
56}
57
58set i [lsearch $argv -halt]
59if {$i>=0} {
60  set HALT 1
61  set argv [lreplace $argv $i $i]
62} else {
63  set HALT 0
64}
65
66set i [lsearch $argv -prot]
67if {$i>=0} {
68  set PROT 1
69  set argv [lreplace $argv $i $i]
70} else {
71  set PROT 0
72}
73
74set i [lsearch $argv -verbose]
75if {$i>=0} {
76  set VERBOSE 1
77  set argv [lreplace $argv $i $i]
78} else {
79  set VERBOSE 0
80}
81
82set i [lsearch $argv -quiet]
83if {$i>=0} {
84  set QUIET 1
85  set argv [lreplace $argv $i $i]
86} else {
87  set QUIET 0
88}
89
90set i [lsearch $argv -strict]
91if {$i>=0} {
92  set STRICT 1
93  set argv [lreplace $argv $i $i]
94} else {
95  set STRICT 0
96}
97
98if {[llength $argv]==0} {
99  foreach f [lsort [glob $testdir/*.test]] {
100    set base [file root [file tail $f]]
101    lappend argv $base
102  }
103}
104
105# start protocol
106#
107proc protInit {cmd} {
108  if {$::PROT} {
109    set out [open [file join $::testrundir prot] w]
110    fconfigure $out -translation platform
111    puts $out "starting tests with: $cmd"
112    close $out
113  }
114}
115
116# write protocol
117#
118proc protOut {msg {noQuiet 0}} {
119  if {$noQuiet || !$::QUIET} {
120    puts stdout $msg
121  }
122  if {$::PROT} {
123    set out [open [file join $::testrundir prot] a]
124    fconfigure $out -translation platform
125    puts $out $msg
126    close $out
127  }
128}
129
130# write a dict with just enough formatting
131# to make it human readable
132#
133proc protOutDict {dict {pattern *}} {
134   set longest [tcl::mathfunc::max 0 {*}[lmap key [dict keys $dict $pattern] {string length $key}]]
135   dict for {key value} $dict {
136      protOut [format "%-${longest}s = %s" $key $value]
137   }
138}
139
140
141# Run the Fossil program with the specified arguments.
142#
143# Consults the VERBOSE global variable to determine if
144# diagnostics should be emitted when no error is seen.
145# Sets the CODE and RESULT global variables for use in
146# test expressions.
147#
148proc fossil {args} {
149  return [uplevel 1 fossil_maybe_answer [list ""] $args]
150}
151
152# Run the Fossil program with the specified arguments
153# and possibly answer the first prompt, if any.
154#
155# Consults the VERBOSE global variable to determine if
156# diagnostics should be emitted when no error is seen.
157# Sets the CODE and RESULT global variables for use in
158# test expressions.
159#
160proc fossil_maybe_answer {answer args} {
161  global fossilexe
162  set cmd $fossilexe
163  set expectError 0
164  set index [lsearch -exact $args -expectError]
165  if {$index != -1} {
166    set expectError 1
167    set args [lreplace $args $index $index]
168  }
169  set keepNewline 0
170  set index [lsearch -exact $args -keepNewline]
171  if {$index != -1} {
172    set keepNewline 1
173    set args [lreplace $args $index $index]
174  }
175  set whatIf 0
176  set index [lsearch -exact $args -whatIf]
177  if {$index != -1} {
178    set whatIf 1
179    set args [lreplace $args $index $index]
180  }
181  foreach a $args {
182    lappend cmd $a
183  }
184  protOut $cmd
185
186  flush stdout
187  if {$whatIf} {
188    protOut [pwd]; protOut $answer
189    set result WHAT-IF-MODE; set rc 42
190  } else {
191    if {[string length $answer] > 0} {
192      protOut $answer
193      set prompt_file [file join $::tempPath fossil_prompt_answer]
194      write_file $prompt_file $answer\n
195      set execCmd [list eval exec]
196      if {$keepNewline} {lappend execCmd -keepnewline}
197      lappend execCmd $cmd <$prompt_file
198      set rc [catch $execCmd result]
199      file delete $prompt_file
200    } else {
201      set execCmd [list eval exec]
202      if {$keepNewline} {lappend execCmd -keepnewline}
203      lappend execCmd $cmd
204      set rc [catch $execCmd result]
205    }
206  }
207  set ab(str) {child process exited abnormally}
208  set ab(len) [string length $ab(str)]
209  set ab(off) [expr {$ab(len) - 1}]
210  if {$rc && $expectError && \
211      [string range $result end-$ab(off) end] eq $ab(str)} {
212    set result [string range $result 0 end-$ab(len)]
213  }
214  global RESULT CODE
215  set CODE $rc
216  if {!$whatIf} {
217    if {($rc && !$expectError) || (!$rc && $expectError)} {
218      protOut "ERROR ($rc): $result" 1
219    } elseif {$::VERBOSE} {
220      protOut "RESULT ($rc): $result"
221    }
222  }
223  set RESULT $result
224}
225
226# Read a file into memory.
227#
228proc read_file {filename} {
229  set in [open $filename r]
230  fconfigure $in -translation binary
231  set txt [read $in [file size $filename]]
232  close $in
233  return $txt
234}
235
236# Write a file to disk
237#
238proc write_file {filename txt} {
239  set out [open $filename w]
240  fconfigure $out -translation binary
241  puts -nonewline $out $txt
242  close $out
243}
244proc write_file_indented {filename txt} {
245  write_file $filename [string trim [string map [list "\n  " \n] $txt]]\n
246}
247
248# Returns the list of all supported versionable settings.
249#
250proc get_versionable_settings {} {
251  #
252  # TODO: If the list of supported versionable settings in "db.c" is modified,
253  #       this list (and procedure) most likely needs to be modified as well.
254  #
255  set result [list \
256      binary-glob \
257      clean-glob \
258      crlf-glob \
259      crnl-glob \
260      dotfiles \
261      empty-dirs \
262      encoding-glob \
263      ignore-glob \
264      keep-glob \
265      manifest]
266
267  return [lsort -dictionary $result]
268}
269
270# Returns the list of all supported settings.
271#
272proc get_all_settings {} {
273  #
274  # TODO: If the list of supported settings in "db.c" is modified, this list
275  #       (and procedure) most likely needs to be modified as well.
276  #
277  set result [list \
278      access-log \
279      admin-log \
280      allow-symlinks \
281      auto-captcha \
282      auto-hyperlink \
283      auto-shun \
284      autosync \
285      autosync-tries \
286      backoffice-disable \
287      backoffice-logfile \
288      backoffice-nodelay \
289      binary-glob \
290      case-sensitive \
291      chat-alert-sound \
292      chat-initial-history \
293      chat-inline-images \
294      chat-keep-count \
295      chat-keep-days \
296      chat-poll-timeout \
297      clean-glob \
298      clearsign \
299      comment-format \
300      crlf-glob \
301      crnl-glob \
302      default-csp \
303      default-perms \
304      diff-binary \
305      diff-command \
306      dont-push \
307      dotfiles \
308      editor \
309      email-admin \
310      email-renew-interval \
311      email-self \
312      email-send-command \
313      email-send-db \
314      email-send-dir \
315      email-send-method \
316      email-send-relayhost \
317      email-subname \
318      email-url \
319      empty-dirs \
320      encoding-glob \
321      exec-rel-paths \
322      fileedit-glob \
323      forbid-delta-manifests \
324      gdiff-command \
325      gmerge-command \
326      hash-digits \
327      hooks \
328      http-port \
329      https-login \
330      ignore-glob \
331      keep-glob \
332      localauth \
333      lock-timeout \
334      main-branch \
335      mainmenu \
336      manifest \
337      max-cache-entry \
338      max-loadavg \
339      max-upload \
340      mimetypes \
341      mtime-changes \
342      pgp-command \
343      preferred-diff-type \
344      proxy \
345      redirect-to-https \
346      relative-paths \
347      repo-cksum \
348      repolist-skin \
349      safe-html \
350      self-register \
351      sitemap-extra \
352      ssh-command \
353      ssl-ca-location \
354      ssl-identity \
355      tclsh \
356      th1-setup \
357      th1-uri-regexp \
358      ticket-default-report \
359      user-color-map \
360      uv-sync \
361      web-browser]
362
363  fossil test-th-eval "hasfeature legacyMvRm"
364
365  if {[normalize_result] eq "1"} {
366    lappend result mv-rm-files
367  }
368
369  fossil test-th-eval "hasfeature tcl"
370
371  if {[normalize_result] eq "1"} {
372    lappend result tcl tcl-setup
373  }
374
375  fossil test-th-eval "hasfeature th1Docs"
376
377  if {[normalize_result] eq "1"} {
378    lappend result th1-docs
379  }
380
381  fossil test-th-eval "hasfeature th1Hooks"
382
383  if {[normalize_result] eq "1"} {
384    lappend result th1-hooks
385  }
386
387  return [lsort -dictionary $result]
388}
389
390# Return true if two files are the same
391#
392proc same_file {a b} {
393  set x [read_file $a]
394  regsub -all { +\n} $x \n x
395  set y [read_file $b]
396  regsub -all { +\n} $y \n y
397  if {$x == $y} {
398    return 1
399  } else {
400    if {$::VERBOSE} {
401      protOut "NOT_SAME_FILE($a): \{\n$x\n\}"
402      protOut "NOT_SAME_FILE($b): \{\n$y\n\}"
403    }
404    return 0
405  }
406}
407
408# Return true if two strings refer to the
409# same uuid. That is, the shorter is a prefix
410# of the longer.
411#
412proc same_uuid {a b} {
413  set na [string length $a]
414  set nb [string length $b]
415  if {$na == $nb} {
416    return [expr {$a eq $b}]
417  }
418  if {$na < $nb} {
419    return [string match "$a*" $b]
420  }
421  return [string match "$b*" $a]
422}
423
424# Return a prefix of a uuid, defaulting to 10 chars.
425#
426proc short_uuid {uuid {len 10}} {
427  string range $uuid 0 $len-1
428}
429
430
431proc require_no_open_checkout {} {
432  if {[info exists ::env(FOSSIL_TEST_DANGEROUS_IGNORE_OPEN_CHECKOUT)] && \
433      $::env(FOSSIL_TEST_DANGEROUS_IGNORE_OPEN_CHECKOUT) eq "YES_DO_IT"} {
434    return
435  }
436  catch {exec $::fossilexe info} res
437  if {[regexp {local-root:} $res]} {
438    set projectName <unknown>
439    set localRoot <unknown>
440    regexp -line -- {^project-name: (.*)$} $res dummy projectName
441    set projectName [string trim $projectName]
442    regexp -line -- {^local-root: (.*)$} $res dummy localRoot
443    set localRoot [string trim $localRoot]
444    error "Detected an open checkout of project \"$projectName\",\
445rooted at \"$localRoot\", testing halted."
446  }
447}
448
449proc get_script_or_fail {} {
450  set fileName [file normalize [info script]]
451  if {[string length $fileName] == 0 || ![file exists $fileName]} {
452    error "Failed to obtain the file name of the test being run."
453  }
454  return $fileName
455}
456
457proc robust_delete { path {force ""} } {
458  set error "unknown error"
459  for {set try 0} {$try < 10} {incr try} {
460    if {$force eq "YES_DO_IT"} {
461      if {[catch {file delete -force $path} error] == 0} {
462        return
463      }
464    } else {
465      if {[catch {file delete $path} error] == 0} {
466        return
467      }
468    }
469    after [expr {$try * 100}]
470  }
471  error "Could not delete \"$path\", error: $error"
472}
473
474proc test_cleanup_then_return {} {
475  uplevel 1 [list test_cleanup]
476  return -code return
477}
478
479proc test_cleanup {} {
480  if {$::KEEP} {return}; # All cleanup disabled?
481  if {![info exists ::tempRepoPath]} {return}
482  if {![file exists $::tempRepoPath]} {return}
483  if {![file isdirectory $::tempRepoPath]} {return}
484  set tempPathEnd [expr {[string length $::tempPath] - 1}]
485  if {[string length $::tempPath] == 0 || \
486      [string range $::tempRepoPath 0 $tempPathEnd] ne $::tempPath} {
487    error "Temporary repository path has wrong parent during cleanup."
488  }
489  if {[info exists ::tempSavedPwd]} {cd $::tempSavedPwd; unset ::tempSavedPwd}
490  # First, attempt to delete the specific temporary repository directories
491  # for this test file.
492  set scriptName [file tail [get_script_or_fail]]
493  foreach repoSeed $::tempRepoSeeds {
494    set repoPath [file join $::tempRepoPath $repoSeed $scriptName]
495    robust_delete $repoPath YES_DO_IT; # FORCE, arbitrary children.
496    set seedPath [file join $::tempRepoPath $repoSeed]
497    robust_delete $seedPath; # NO FORCE.
498  }
499  # Next, attempt to gracefully delete the temporary repository directory
500  # for this process.
501  robust_delete $::tempRepoPath
502  # Finally, attempt to gracefully delete the temporary home directory,
503  # unless forbidden by external forces.
504  if {![info exists ::tempKeepHome]} {delete_temporary_home}
505}
506
507proc delete_temporary_home {} {
508  if {$::KEEP} {return}; # All cleanup disabled?
509  if {$::is_windows} {
510    robust_delete [file join $::tempHomePath _fossil]
511  } else {
512    robust_delete [file join $::tempHomePath .fossil]
513  }
514  robust_delete $::tempHomePath
515}
516
517proc is_home_elsewhere {} {
518  return [expr {[info exists ::env(FOSSIL_HOME)] && \
519      $::env(FOSSIL_HOME) eq $::tempHomePath}]
520}
521
522proc set_home_to_elsewhere {} {
523  #
524  # Fossil will write data on $HOME (or $FOSSIL_HOME).  We need not
525  # to clutter the real $HOME (or $FOSSIL_HOME) of the test caller.
526  #
527  if {[is_home_elsewhere]} {return}
528  set ::env(FOSSIL_HOME) $::tempHomePath
529}
530
531#
532# Create and open a new Fossil repository and clean the checkout
533#
534proc test_setup {{filename ".rep.fossil"}} {
535  set_home_to_elsewhere
536  if {![info exists ::tempRepoPath]} {
537    set ::tempRepoPath [file join $::tempPath repo_[pid]]
538  }
539  set repoSeed [appendArgs [string trim [clock seconds] -] _ [getSeqNo]]
540  lappend ::tempRepoSeeds $repoSeed
541  set repoPath [file join \
542      $::tempRepoPath $repoSeed [file tail [get_script_or_fail]]]
543  if {[catch {
544    file mkdir $repoPath
545  } error] != 0} {
546    error "Could not make directory \"$repoPath\",\
547please set TEMP variable in environment, error: $error"
548  }
549  if {![info exists ::tempSavedPwd]} {set ::tempSavedPwd [pwd]}; cd $repoPath
550  if {[string length $filename] > 0} {
551    exec $::fossilexe new $filename
552    exec $::fossilexe open $filename
553    exec $::fossilexe set mtime-changes off
554  }
555  return $repoPath
556}
557
558# This procedure only returns non-zero if the Tcl integration feature was
559# enabled at compile-time and is now enabled at runtime.
560proc is_tcl_usable_by_fossil {} {
561  fossil test-th-eval "hasfeature tcl"
562  if {[normalize_result] ne "1"} {return 0}
563  fossil test-th-eval "setting tcl"
564  if {[normalize_result] eq "1"} {return 1}
565  fossil test-th-eval --open-config "setting tcl"
566  if {[normalize_result] eq "1"} {return 1}
567  return [info exists ::env(TH1_ENABLE_TCL)]
568}
569
570# This procedure only returns non-zero if the TH1 hooks feature was enabled
571# at compile-time and is now enabled at runtime.
572proc are_th1_hooks_usable_by_fossil {} {
573  fossil test-th-eval "hasfeature th1Hooks"
574  if {[normalize_result] ne "1"} {return 0}
575  fossil test-th-eval "setting th1-hooks"
576  if {[normalize_result] eq "1"} {return 1}
577  fossil test-th-eval --open-config "setting th1-hooks"
578  if {[normalize_result] eq "1"} {return 1}
579  return [info exists ::env(TH1_ENABLE_HOOKS)]
580}
581
582# Run the given command script inside the Fossil source repo checkout.
583#
584# Callers of this function must ensure two things:
585#
586# 1. This test run is in fact being done from within a Fossil repo
587#    checkout directory.  If you are unsure, test $::outside_fossil_repo
588#    or call one of the test_* wrappers below which do that for you.
589#
590#    As a rule, you should not be calling this function directly!
591#
592# 2. This test run is being done from a repo checkout directory that
593#    doesn't have any uncommitted changes.  If it does, that affects the
594#    output of any test based on the output of "fossil status",
595#    "... diff", etc., which is likely to make the test appear to fail.
596#    If you must call this function directly, test $::dirty_ckout and
597#    skip the call if it's true.  The test_* wrappers do this for you.
598#
599# 3. The test does NOT modify the Fossil checkout tree in any way.
600proc run_in_checkout { script {dir ""} } {
601  if {[string length $dir] == 0} {set dir $::testfiledir}
602  set savedPwd [pwd]; cd $dir
603  set code [catch {
604    uplevel 1 $script
605  } result]
606  cd $savedPwd; unset savedPwd
607  return -code $code $result
608}
609
610# Wrapper for the above function pair.  The tscript parameter is an
611# optional post-run test script.  Some callers choose instead to put
612# the tests inline with the rscript commands.
613#
614# Be sure to adhere to the requirements of run_in_checkout!
615proc test_block_in_checkout { name rscript {tscript ""} } {
616  if {$::outside_fossil_repo || $::dirty_ckout} {
617    set $::CODE 0
618    set $::RESULT ""
619  } else {
620    uplevel 1 [list run_in_checkout $rscript]
621    if {[string length $tscript] == 0} {
622      return ""
623    } else {
624      set code [catch {
625        uplevel 1 $tscript
626      } result]
627      return -code $code $result
628    }
629  }
630}
631
632# Single-test wrapper for the above.
633proc test_in_checkout { name rscript tscript } {
634  return test_block_in_checkout name rscript {
635    test $name $tscript
636  }
637}
638
639# Normalize file status lists (like those returned by 'fossil changes')
640# so they can be compared using simple string comparison
641#
642proc normalize_status_list {list} {
643  set normalized [list]
644  set matches [regexp -all -inline -line {^\s*([A-Z_]+:?)\x20+(\S.*)$} $list]
645  foreach {_ status file} $matches {
646    lappend normalized [list $status [string trim $file]]
647  }
648  set normalized [lsort -index 1 $normalized]
649  return $normalized
650}
651
652# Perform a test comparing two status lists
653#
654proc test_status_list {name result expected {constraints ""}} {
655  set expected [normalize_status_list $expected]
656  set result [normalize_status_list $result]
657  if {$result eq $expected} {
658    test $name 1 $constraints
659  } else {
660    protOut "  Expected:\n    [join $expected "\n    "]" 1
661    protOut "  Got:\n    [join $result "\n    "]" 1
662    test $name 0 $constraints
663  }
664}
665
666# Perform a test on the contents of a file
667#
668proc test_file_contents {name path expected {constraints ""}} {
669  if {[file exists $path]} {
670    set result [read_file $path]
671    set passed [expr {$result eq $expected}]
672    if {!$passed} {
673      set expectedLines [split $expected "\n"]
674      set resultLines [split $result "\n"]
675      protOut "  Expected:\n    [join $expectedLines "\n    "]" 1
676      protOut "  Got:\n    [join $resultLines "\n    "]" 1
677    }
678  } else {
679    set passed 0
680    protOut "  File does not exist: $path" 1
681  }
682  test $name $passed $constraints
683}
684
685# Append all arguments into a single value and then returns it.
686#
687proc appendArgs {args} {
688  eval append result $args
689}
690
691# Returns the value of the specified environment variable -OR- any empty
692# string if it does not exist.
693#
694proc getEnvironmentVariable { name } {
695  return [expr {[info exists ::env($name)] ? $::env($name) : ""}]
696}
697
698# Returns a usable temporary directory -OR- fails the testing process.
699#
700proc getTemporaryPath {} {
701  #
702  # NOTE: Build the list of "temporary directory" environment variables
703  #       to check, including all reasonable "cases" of the environment
704  #       variable names.
705  #
706  set names [list]
707
708  #
709  # TODO: Add more here, if necessary.
710  #
711  foreach name [list FOSSIL_TEST_TEMP FOSSIL_TEMP TEMP TMP] {
712    lappend names [string toupper $name] [string tolower $name] \
713        [string totitle $name]
714  }
715
716  #
717  # NOTE: Check if we can use any of the environment variables.
718  #
719  foreach name $names {
720    set value [getEnvironmentVariable $name]
721
722    if {[string length $value] > 0} {
723      set value [file normalize $value]
724
725      if {[file exists $value] && [file isdirectory $value]} {
726        return $value
727      }
728    }
729  }
730
731  #
732  # NOTE: On non-Windows systems, fallback to /tmp if it is usable.
733  #
734  if {!$::is_windows} {
735    set value /tmp
736
737    if {[file exists $value] && [file isdirectory $value]} {
738      return $value
739    }
740  }
741
742  #
743  # NOTE: There must be a usable temporary directory to continue testing.
744  #
745  error "Cannot find a usable temporary directory, testing halted."
746}
747
748# Return the name of the versioned settings file containing the TH1
749# setup script.
750#
751proc getTh1SetupFileName {} {
752  #
753  # NOTE: This uses the "testdir" global variable provided by the
754  #       test suite; alternatively, the root of the source tree
755  #       could be obtained directly from Fossil.
756  #
757  return [file normalize [file join .fossil-settings th1-setup]]
758}
759
760# Return the saved name of the versioned settings file containing
761# the TH1 setup script.
762#
763proc getSavedTh1SetupFileName {} {
764  return [appendArgs [getTh1SetupFileName] . [pid]]
765}
766
767# Sets the TH1 setup script to the one provided.  Prior to calling
768# this, the [saveTh1SetupFile] procedure should be called in order to
769# preserve the existing TH1 setup script.  Prior to completing the test,
770# the [restoreTh1SetupFile] procedure should be called to restore the
771# original TH1 setup script.
772#
773proc writeTh1SetupFile { data } {
774  set fileName [getTh1SetupFileName]
775  file mkdir [file dirname $fileName]
776  return [write_file $fileName $data]
777}
778
779# Saves the TH1 setup script file by renaming it, based on the current
780# process ID.
781#
782proc saveTh1SetupFile {} {
783  set oldFileName [getTh1SetupFileName]
784  if {[file exists $oldFileName]} {
785    set newFileName [getSavedTh1SetupFileName]
786    catch {file delete $newFileName}
787    file rename $oldFileName $newFileName
788  }
789}
790
791# Restores the original TH1 setup script file by renaming it back, based
792# on the current process ID.
793#
794proc restoreTh1SetupFile {} {
795  set oldFileName [getSavedTh1SetupFileName]
796  set newFileName [getTh1SetupFileName]
797  if {[file exists $oldFileName]} {
798    catch {file delete $newFileName}
799    file rename $oldFileName $newFileName
800  } else {
801    #
802    # NOTE: There was no TH1 setup script file, delete the test one.
803    #
804    file delete $newFileName
805  }
806}
807
808# Perform a test
809#
810set test_count 0
811proc test {name expr {constraints ""}} {
812  global bad_test ignored_test test_count RESULT
813  incr test_count
814  set knownBug [expr {"knownBug" in $constraints}]
815  set r [uplevel 1 [list expr $expr]]
816  if {$r} {
817    if {$knownBug && !$::STRICT} {
818      protOut "test $name OK (knownBug)?"
819    } else {
820      protOut "test $name OK"
821    }
822  } else {
823    if {$knownBug && !$::STRICT} {
824      protOut "test $name FAILED (knownBug)!" 1
825      lappend ignored_test $name
826    } else {
827      protOut "test $name FAILED!" 1
828      if {$::QUIET} {protOut "RESULT: $RESULT" 1}
829      lappend bad_test $name
830      if {$::HALT} {exit 1}
831    }
832  }
833}
834set bad_test {}
835set ignored_test {}
836
837# Return a random string N characters long.
838#
839set vocabulary 01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
840append vocabulary "       ()*^!.eeeeeeeeaaaaattiioo   "
841set nvocabulary [string length $vocabulary]
842proc rand_str {N} {
843  global vocabulary nvocabulary
844  set out {}
845  while {$N>0} {
846    incr N -1
847    set i [expr {int(rand()*$nvocabulary)}]
848    append out [string index $vocabulary $i]
849  }
850  return $out
851}
852
853# Make random changes to a file.
854#
855# The file is divided into blocks of $blocksize lines each.  The first
856# block is number 0.  Changes are only made within blocks where
857# the block number divided by $count has a remainder of $index.
858#
859# For any given line that mets the block count criteria, the probably
860# of a change is $prob
861#
862# Changes do not add or remove newlines
863#
864proc random_changes {body blocksize count index prob} {
865  set out {}
866  set blockno 0
867  set lineno -1
868  foreach line [split $body \n] {
869    incr lineno
870    if {$lineno==$blocksize} {
871      incr blockno
872      set lineno 0
873    }
874    if {$blockno%$count==$index && rand()<$prob} {
875      set n [string length $line]
876      if {$n>5 && rand()<0.5} {
877        # delete part of the line
878        set n [expr {int(rand()*$n)}]
879        set i [expr {int(rand()*$n)}]
880        set k [expr {$i+$n}]
881        set line [string range $line 0 $i][string range $line $k end]
882      } else {
883        # insert something into the line
884        set stuff [rand_str [expr {int(rand()*($n-5))-1}]]
885        set i [expr {int(rand()*$n)}]
886        set ip1 [expr {$i+1}]
887        set line [string range $line 0 $i]$stuff[string range $line $ip1 end]
888      }
889    }
890    append out \n$line
891  }
892  return [string range $out 1 end]
893}
894
895# This procedure executes the "fossil server" command.  The return value
896# is a list comprised of the new process identifier and the port on which
897# the server started.  The varName argument refers to a variable
898# where the "stop argument" is to be stored.  This value must eventually be
899# passed to the [test_stop_server] procedure.
900proc test_start_server { repository {varName ""} } {
901  global fossilexe tempPath
902  set command [list exec $fossilexe server --localhost]
903  if {[string length $varName] > 0} {
904    upvar 1 $varName stopArg
905  }
906  if {$::is_windows} {
907    set stopArg [file join [getTemporaryPath] [appendArgs \
908        [string trim [clock seconds] -] _ [getSeqNo] .stopper]]
909    lappend command --stopper $stopArg
910  }
911  set outFileName [file join $tempPath [appendArgs \
912      fossil_server_ [string trim [clock seconds] -] _ \
913      [getSeqNo]]].out
914  lappend command $repository >&$outFileName &
915  set pid [eval $command]
916  if {!$::is_windows} {
917    set stopArg $pid
918  }
919  after 1000; # output might not be there yet
920  set output [read_file $outFileName]
921  if {![regexp {Listening.*TCP port (\d+)} $output dummy port]} {
922    puts stdout "Could not detect Fossil server port, using default..."
923    set port 8080; # return the default port just in case
924  }
925  return [list $pid $port $outFileName]
926}
927
928# This procedure stops a Fossil server instance that was previously started
929# by the [test_start_server] procedure.  The value of the "stop argument"
930# will vary by platform as will the exact method used to stop the server.
931# The fileName argument is the name of a temporary output file to delete.
932proc test_stop_server { stopArg pid fileName } {
933  if {$::is_windows} {
934    #
935    # NOTE: On Windows, the "stop argument" must be the name of a file
936    #       that does NOT already exist.
937    #
938    if {[string length $stopArg] > 0 && \
939        ![file exists $stopArg] && \
940        [catch {write_file $stopArg [clock seconds]}] == 0} {
941      while {1} {
942        if {[catch {
943          #
944          # NOTE: Using the TaskList utility requires Windows XP or
945          #       later.
946          #
947          exec tasklist.exe /FI "PID eq $pid"
948        } result] != 0 || ![regexp -- " $pid " $result]} {
949          break
950        }
951        after 1000; # wait a bit...
952      }
953      file delete $stopArg
954      if {[string length $fileName] > 0} {
955        file delete $fileName
956      }
957      return true
958    }
959  } else {
960    #
961    # NOTE: On Unix, the "stop argument" must be an integer identifier
962    #       that refers to an existing process.
963    #
964    if {[regexp {^(?:-)?\d+$} $stopArg] && \
965        [catch {exec kill -TERM $stopArg}] == 0} {
966      while {1} {
967        if {[catch {
968          #
969          # TODO: Is this portable to all the supported variants of
970          #       Unix?  It should be, it's POSIX.
971          #
972          exec ps -p $pid
973        } result] != 0 || ![regexp -- "(?:^$pid| $pid) " $result]} {
974          break
975        }
976        after 1000; # wait a bit...
977      }
978      if {[string length $fileName] > 0} {
979        file delete $fileName
980      }
981      return true
982    }
983  }
984  return false
985}
986
987# Executes the "fossil http" command.  The entire content of the HTTP request
988# is read from the data file name, with [subst] being performed on it prior to
989# submission.  Temporary input and output files are created and deleted.  The
990# result will be the contents of the temoprary output file.
991proc test_fossil_http { repository dataFileName url } {
992  set suffix [appendArgs [pid] - [getSeqNo] - [clock seconds] .txt]
993  set inFileName [file join $::tempPath [appendArgs test-http-in- $suffix]]
994  set outFileName [file join $::tempPath [appendArgs test-http-out- $suffix]]
995  set data [subst [read_file $dataFileName]]
996
997  write_file $inFileName $data
998
999  fossil http --in $inFileName --out $outFileName --ipaddr 127.0.0.1 \
1000      $repository --localauth --th-trace
1001
1002  set result [expr {[file exists $outFileName] ? [read_file $outFileName] : ""}]
1003
1004  if {1} {
1005    catch {file delete $inFileName}
1006    catch {file delete $outFileName}
1007  }
1008
1009  return $result
1010}
1011
1012# obtains and increments a "sequence number" for this test run.
1013proc getSeqNo {} {
1014  upvar #0 seqNo seqNo
1015  if {![info exists seqNo]} {
1016    set seqNo 0
1017  }
1018  return [incr seqNo]
1019}
1020
1021# fixup the whitespace in the result to make it easier to compare.
1022proc normalize_result {} {
1023  return [string map [list \r\n \n] [string trim $::RESULT]]
1024}
1025
1026# fixup the line-endings in the result to make it easier to compare.
1027proc normalize_result_no_trim {} {
1028  return [string map [list \r\n \n] $::RESULT]
1029}
1030
1031# returns the first line of the normalized result.
1032proc first_data_line {} {
1033  return [lindex [split [normalize_result] \n] 0]
1034}
1035
1036# returns the second line of the normalized result.
1037proc second_data_line {} {
1038  return [lindex [split [normalize_result] \n] 1]
1039}
1040
1041# returns the third line of the normalized result.
1042proc third_data_line {} {
1043  return [lindex [split [normalize_result] \n] 2]
1044}
1045
1046# returns the last line of the normalized result.
1047proc last_data_line {} {
1048  return [lindex [split [normalize_result] \n] end]
1049}
1050
1051# returns the second to last line of the normalized result.
1052proc next_to_last_data_line {} {
1053  return [lindex [split [normalize_result] \n] end-1]
1054}
1055
1056# returns the third to last line of the normalized result.
1057proc third_to_last_data_line {} {
1058  return [lindex [split [normalize_result] \n] end-2]
1059}
1060
1061set tempPath [getTemporaryPath]
1062
1063if {$is_windows} {
1064  set tempPath [string map [list \\ /] $tempPath]
1065}
1066
1067if {[catch {
1068  set tempFile [file join $tempPath temporary.txt]
1069  write_file $tempFile [clock seconds]; file delete $tempFile
1070} error] != 0} {
1071  error "Could not write file \"$tempFile\" in directory \"$tempPath\",\
1072please set TEMP variable in environment, error: $error"
1073}
1074
1075set tempHomePath [file join $tempPath home_[pid]]
1076
1077if {[catch {
1078  file mkdir $tempHomePath
1079} error] != 0} {
1080  error "Could not make directory \"$tempHomePath\",\
1081please set TEMP variable in environment, error: $error"
1082}
1083
1084
1085protInit $fossilexe
1086set ::tempKeepHome 1
1087foreach testfile $argv {
1088  protOut "***** $testfile ******"
1089  if { [catch {source $testdir/$testfile.test} testerror testopts] } {
1090    test test-framework-$testfile 0
1091    protOut "!!!!! $testfile: $testerror"
1092    protOutDict $testopts"
1093  } else {
1094    test test-framework-$testfile 1
1095  }
1096  protOut "***** End of $testfile: [llength $bad_test] errors so far ******"
1097}
1098unset ::tempKeepHome; delete_temporary_home
1099set nErr [llength $bad_test]
1100if {$nErr>0 || !$::QUIET} {
1101  protOut "***** Final results: $nErr errors out of $test_count tests" 1
1102}
1103if {$nErr>0} {
1104  protOut "***** Considered failures: $bad_test" 1
1105}
1106set nErr [llength $ignored_test]
1107if {$nErr>0 || !$::QUIET} {
1108  protOut "***** Ignored results: $nErr ignored errors out of $test_count tests" 1
1109}
1110if {$nErr>0} {
1111  protOut "***** Ignored failures: $ignored_test" 1
1112}
1113