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

Subversion Repositories or1k_old

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

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

powered by: WebSVN 2.1.0

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