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