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

Subversion Repositories or1k_old

[/] [or1k_old/] [tags/] [start/] [insight/] [itcl/] [iwidgets3.0.0/] [incoming/] [tests/] [defs] - Blame information for rev 1765

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 
# Copyright (c) 1994 Sun Microsystems, Inc.
7 
#
8 
# See the file "license.terms" for information on usage and redistribution
9 
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
10 
#
11 
# @(#) defs 1.7 94/12/17 15:53:52
12 
 
13 
if ![info exists VERBOSE] {
14 
    set VERBOSE 0
15 
}
16 
if ![info exists DELAY] {
17 
    set DELAY 0
18 
}
19 
if ![info exists TESTS] {
20 
    set TESTS {}
21 
}
22 
 
23 
# Some of the tests don't work on some system configurations due to
24 
# configuration quirks, not due to Tk problems;  in order to prevent
25 
# false alarms, these tests are only run in the master development
26 
# directory for Tk.  The presence of a file "doAllTests" in this
27 
# directory is used to indicate that these tests should be run.
28 
 
29 
set doNonPortableTests [file exists doAllTests]
30 
 
31 
proc print_verbose {test_name test_description contents_of_test code answer} {
32 
    puts stdout "\n"
33 
    puts stdout "==== $test_name $test_description"
34 
    puts stdout "==== Contents of test case:"
35 
    puts stdout "$contents_of_test"
36 
    if {$code != 0} {
37 
        if {$code == 1} {
38 
            puts stdout "==== Test generated error:"
39 
            puts stdout $answer
40 
        } elseif {$code == 2} {
41 
            puts stdout "==== Test generated return exception;  result was:"
42 
            puts stdout $answer
43 
        } elseif {$code == 3} {
44 
            puts stdout "==== Test generated break exception"
45 
        } elseif {$code == 4} {
46 
            puts stdout "==== Test generated continue exception"
47 
        } else {
48 
            puts stdout "==== Test generated exception $code;  message was:"
49 
            puts stdout $answer
50 
        }
51 
    } else {
52 
        puts stdout "==== Result was:"
53 
        puts stdout "$answer"
54 
    }
55 
}
56 
 
57 
proc test {test_name test_description contents_of_test passing_results} {
58 
    global VERBOSE
59 
    global TESTS
60 
    global DELAY
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 \
83 
                $code $answer
84 
        puts stdout "---- Result should have been:"
85 
        puts stdout "$passing_results"
86 
        puts stdout "---- $test_name FAILED"
87 
    }
88 
    after $DELAY
89 
}
90 
 
91 
#
92 
# Like test, but does reg expr check on the results.
93 
# Useful when the result must follow a pattern but some exact details
94 
# are not necessary, like an internal number appended to a frame, etc.
95 
#
96 
proc test_pattern {test_name test_description contents_of_test passing_results} {
97 
        global VERBOSE
98 
        global TESTS
99 
        if {[string compare $TESTS ""] != 0} then {
100 
                set ok 0
101 
                foreach test $TESTS {
102 
                        if [string match $test $test_name] then {
103 
                        set ok 1
104 
                        break
105 
                        }
106 
                }
107 
                if !$ok then return
108 
        }
109 
 
110 
        set code [catch {uplevel $contents_of_test} answer]
111 
 
112 
        if {$code != 0} {
113 
                print_verbose $test_name $test_description $contents_of_test \
114 
                        $code $answer
115 
        } elseif {[regexp -- [lindex $passing_results 1] [lindex $answer 1]] == 1 } {
116 
                if $VERBOSE then {
117 
                        print_verbose $test_name $test_description $contents_of_test \
118 
                                $code $answer
119 
                        puts stdout "++++ $test_name PASSED"
120 
                }
121 
        } else {
122 
                print_verbose $test_name $test_description $contents_of_test \
123 
                        $code $answer
124 
                puts stdout "---- Result should have been:"
125 
                puts stdout "$passing_results"
126 
                puts stdout "**** $test_name FAILED ****"
127 
        }
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 
}
137 
 
138 
# If the main window isn't already mapped (e.g. because the tests are
139 
# being run automatically) , specify a precise size for it so that the
140 
# user won't have to position it manually.
141 
 
142 
if {![winfo ismapped .]} {
143 
    wm geometry . +0+0
144 
    update
145 
}
146 
 
147 
# The following code can be used to perform tests involving a second
148 
# process running in the background.
149 
 
150 
# Locate tktest executable
151 
global argv0
152 
if {0} {
153 
puts "file executable $argv0...[file executable $argv0]"
154 
if { [file executable $argv0] } {
155 
    if { [string index $argv0 0] == "/" } {
156 
        set tktest $argv0
157 
    } else {
158 
        set tktest "[pwd]/$argv0"
159 
    }
160 
} elseif { [file executable ../$argv0] } {
161 
    set tktest "[pwd]/../$argv0"
162 
} else {
163 
    set tktest {}
164 
    puts "Unable to find tktest executable, skipping multiple process tests."
165 
}
166 
} else {set tktest ../tktest}
167 
 
168 
# Create background process
169 
proc setupbg {{args ""}} {
170 
    global tktest fd bgData
171 
    set fd [open "|$tktest -geometry +0+0 $args" r+]
172 
    puts $fd "puts foo; flush stdout"
173 
    flush $fd
174 
    gets $fd
175 
    fileevent $fd readable bgReady
176 
}
177 
 
178 
# Send a command to the background process, catching errors and
179 
# flushing I/O channels
180 
proc dobg {command} {
181 
    global fd bgData bgDone
182 
    puts $fd "catch {$command} msg; update; puts \$msg; puts **DONE**; flush stdout"
183 
    flush $fd
184 
    set bgDone 0
185 
    set bgData {}
186 
    tkwait variable bgDone
187 
    set bgData
188 
}
189 
 
190 
# Data arrived from background process.  Check for special marker
191 
# indicating end of data for this command, and make data available
192 
# to dobg procedure.
193 
proc bgReady {} {
194 
    global fd bgData bgDone
195 
    set x [gets $fd]
196 
    if [eof $fd] {
197 
        fileevent $fd readable {}
198 
        set bgDone 1
199 
    } elseif {$x == "**DONE**"} {
200 
        set bgDone 1
201 
    } else {
202 
        append bgData $x
203 
    }
204 
}
205 
 
206 
# Exit the background process, and close the pipes
207 
proc cleanupbg {} {
208 
    global fd
209 
    catch {
210 
        puts $fd "exit"
211 
        close $fd
212 
    }
213 
}

powered by: WebSVN 2.1.0

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