OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [expect/] [tests/] [defs] - Blame information for rev 578

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
# 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 
 
6 
if ![info exists VERBOSE] {
7 
        set VERBOSE 0
8 
}
9 
set TESTS {}
10 
set auto_noexec 1
11 
set auto_noload 1
12 
catch {rename unknown ""}
13 
 
14 
# If tests are being run as root, issue a warning message and set a
15 
# variable to prevent some tests from running at all.
16 
 
17 
set user {}
18 
catch {set user [exec whoami]}
19 
if {$user == "root"} {
20 
    puts stdout "Warning: you're executing as root.  I'll have to"
21 
    puts stdout "skip some of the tests, since they'll fail as root."
22 
}
23 
 
24 
# Some of the tests don't work on some system configurations due to
25 
# configuration quirks, not due to Tcl problems;  in order to prevent
26 
# false alarms, these tests are only run in the master source directory
27 
# at Berkeley.  The presence of a file "Berkeley" in this directory is
28 
# used to indicate that these tests should be run.
29 
 
30 
set atBerkeley [file exists Berkeley]
31 
 
32 
proc print_verbose {test_name test_description contents_of_test code answer} {
33 
    puts stdout "\n"
34 
    puts stdout "==== $test_name $test_description"
35 
    puts stdout "==== Contents of test case:"
36 
    puts stdout "$contents_of_test"
37 
    if {$code != 0} {
38 
        if {$code == 1} {
39 
            puts stdout "==== Test generated error:"
40 
            puts stdout $answer
41 
        } elseif {$code == 2} {
42 
            puts stdout "==== Test generated return exception;  result was:"
43 
            puts stdout $answer
44 
        } elseif {$code == 3} {
45 
            puts stdout "==== Test generated break exception"
46 
        } elseif {$code == 4} {
47 
            puts stdout "==== Test generated continue exception"
48 
        } else {
49 
            puts stdout "==== Test generated exception $code;  message was:"
50 
            puts stdout $answer
51 
        }
52 
    } else {
53 
        puts stdout "==== Result was:"
54 
        puts stdout "$answer"
55 
    }
56 
}
57 
 
58 
proc test {test_name test_description contents_of_test passing_results} {
59 
    global VERBOSE
60 
    global TESTS
61 
    if {[string compare $TESTS ""] != 0} then {
62 
        set ok 0
63 
        foreach test $TESTS {
64 
            if [string match $test $test_name] then {
65 
                set ok 1
66 
                break
67 
            }
68 
        }
69 
        if !$ok then return
70 
    }
71 
    set code [catch {uplevel $contents_of_test} answer]
72 
    if {$code != 0} {
73 
        print_verbose $test_name $test_description $contents_of_test \
74 
                $code $answer
75 
    } elseif {[string compare $answer $passing_results] == 0} then {
76 
        if $VERBOSE then {
77 
            print_verbose $test_name $test_description $contents_of_test \
78 
                    $code $answer
79 
            puts stdout "++++ $test_name PASSED"
80 
        }
81 
    } else {
82 
        print_verbose $test_name $test_description $contents_of_test $code \
83 
                $answer
84 
        puts stdout "---- Result should have been:"
85 
        puts stdout "$passing_results"
86 
        puts stdout "---- $test_name FAILED"
87 
    }
88 
}
89 
 
90 
# stick it in a file, run, and test by looking at output
91 
proc ftest {test_name test_description contents_of_test passing_results} {
92 
    global VERBOSE
93 
    global TESTS
94 
    global objdir
95 
    if {[string compare $TESTS ""] != 0} then {
96 
        set ok 0
97 
        foreach test $TESTS {
98 
            if [string match $test $test_name] then {
99 
                set ok 1
100 
                break
101 
            }
102 
        }
103 
        if !$ok then return
104 
    }
105 
 
106 
    set file [open /tmp/[pid] w]
107 
    puts $file $contents_of_test
108 
    close $file
109 
 
110 
    set code [catch {exec $objdir/expect /tmp/[pid]} answer]
111 
    if {$code != 0} {
112 
        print_verbose $test_name $test_description $contents_of_test \
113 
                $code $answer
114 
    } elseif {[string compare $answer $passing_results] == 0} then {
115 
        if $VERBOSE then {
116 
            print_verbose $test_name $test_description $contents_of_test \
117 
                    $code $answer
118 
            puts stdout "++++ $test_name PASSED"
119 
        }
120 
    } else {
121 
        print_verbose $test_name $test_description $contents_of_test $code \
122 
                $answer
123 
        puts stdout "---- Result should have been:"
124 
        puts stdout "$passing_results"
125 
        puts stdout "---- $test_name FAILED"
126 
    }
127 
    catch {exec rm -f /tmp/[pid]}
128 
}
129 
 
130 
proc dotests {file args} {
131 
    global TESTS
132 
    set savedTests $TESTS
133 
    set TESTS $args
134 
    source $file
135 
    set TESTS $savedTests
136 
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.