source: trunk/la1.0/defs

Last change on this file was 931, checked in by toby, 11 years ago

include rest of files

File size: 2.8 KB
Line 
1# This file contains support code for the Tcl test suite.  It is
2# normally sourced by the individual files in the test suite before
3# they run their tests.  This improved approach to testing was designed
4# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
5# This file is NOT Copyright by Hume Integration
6#
7set VERBOSE 0
8set TESTS {}
9set auto_noexec 1
10
11
12# If tests are being run as root, issue a warning message and set a
13# variable to prevent some tests from running at all.
14
15set user {}
16catch {set user [exec whoami]}
17
18
19# Some of the tests don't work on some system configurations due to
20# configuration quirks, not due to Tcl problems;  in order to prevent
21# false alarms, these tests are only run in the master source directory
22# at Berkeley.  The presence of a file "Berkeley" in this directory is
23# used to indicate that these tests should be run.
24
25set atBerkeley [file exists Berkeley]
26
27proc print_verbose {test_name test_description contents_of_test code answer} {
28    puts stdout "\n"
29    puts stdout "==== $test_name $test_description"
30    puts stdout "==== Contents of test case:"
31    puts stdout "$contents_of_test"
32    if {$code != 0} {
33        if {$code == 1} {
34            puts stdout "==== Test generated error:"
35            puts stdout $answer
36        } elseif {$code == 2} {
37            puts stdout "==== Test generated return exception;  result was:"
38            puts stdout $answer
39        } elseif {$code == 3} {
40            puts stdout "==== Test generated break exception"
41        } elseif {$code == 4} {
42            puts stdout "==== Test generated continue exception"
43        } else {
44            puts stdout "==== Test generated exception $code;  message was:"
45            puts stdout $answer
46        }
47    } else {
48        puts stdout "==== Result was:"
49        puts stdout "$answer"
50    }
51}
52
53proc test {test_name test_description contents_of_test passing_results} {
54    global VERBOSE
55    global TESTS
56    if {[string compare $TESTS ""] != 0} then {
57        set ok 0
58        foreach test $TESTS {
59            if [string match $test $test_name] then {
60                set ok 1
61                break
62            }
63        }
64        if !$ok then return
65    }
66    set code [catch {uplevel $contents_of_test} answer]
67    if {$code != 0} {
68        print_verbose $test_name $test_description $contents_of_test \
69                $code $answer
70    } elseif {[string compare $answer $passing_results] == 0} then {
71        if $VERBOSE then {
72            print_verbose $test_name $test_description $contents_of_test \
73                    $code $answer
74            puts stdout "++++ $test_name PASSED"
75        }
76    } else {
77        print_verbose $test_name $test_description $contents_of_test $code \
78                $answer
79        puts stdout "---- Result should have been:"
80        puts stdout "$passing_results"
81        puts stdout "---- $test_name FAILED"
82    }
83}
84
85proc dotests {file args} {
86    global TESTS
87    set savedTests $TESTS
88    set TESTS $args
89    source $file
90    set TESTS $savedTests
91}
92
Note: See TracBrowser for help on using the repository browser.