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

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tix/] [tests/] [Driver.tcl] - Blame information for rev 1778

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


# This is the "Test Driver" program that sources in each test script. It
# must be invoked by the test/Test.tcl program (in Unix) or by a properly
# configured wish.exe program (in Wondows).
#
 
catch {
    cd [file dirname [info script]]
}
 
set oldglobals {}
set oldglobals [info globals]
 
# Some parts of the test execute tests for a specific platform. The variable
# tixPriv(test:platform) controls the tests for which platform should
# be executed. This can be controlled by the TEST_PLATFORM environment
# variable 
 
set tixPriv(test:platform) unix
if [info exists tcl_platform(platform)] {
    if {$tcl_platform(platform) == "windows"} {
        set tixPriv(test:platform) windows
    }
}
 
if [info exists env(TEST_PLATFORM)] {
    set tixPriv(test:platform) $env(TEST_PLATFORM)
}
 
global testConfig
if {![info exists tix]} {
    if ![info exists tcl_platform(platform)] {
        puts "ERROR: this version of wish doesn't support dynamic loading"
        exit -1
    }
 
    # This must have been executed by a plain wish expecting to
    # dynamic load Tix.
 
    puts -nonewline "trying to dynamically load Tix ... "
 
    global tk_version
    if {$tcl_platform(platform) == "unix"} {
        case $tk_version {
            4.1 {
                set testConfig(dynlib) \
                    ../unix/tk4.1/libtix4.1.4.1[info sharedlibextension]
            }
            4.2 {
                set testConfig(dynlib) \
                    ../unix/tk4.2/libtix4.1.4.2[info sharedlibextension]
            }
        }
    } else {
        case $tk_version {
            4.1 {
                set testConfig(dynlib) ..\\win\\tix41.dll
            }
            4.2 {
                set testConfig(dynlib) ..\\win\\tix41.dll
            }
        }
    }
 
    if [info exists testConfig(dynlib)] {
        load $testConfig(dynlib) Tix
    }
 
    if {[info exists tix]} {
        puts succeeded
    } else {
        puts failed
        exit
    }
} else {
    set testConfig(dynlib) ""
}
 
proc Driver:Test {name f} {
    global oldglobals errorInfo testConfig
 
    foreach w [winfo children .] {
        if [string comp .__top $w] {
            destroy $w
        }
    }
 
    foreach g [info globals] {
        if {[lsearch $oldglobals $g] == -1} {
#           uplevel #0 unset $g
        }
    }
 
    if {$testConfig(VERBOSE) >= 20} {
        puts ------------------------------------------------------------
        puts "Loading script $name"
    } else {
        puts $name
    }
 
    update
    uplevel #0 source $f
    Event-Initialize
    catch {
        wm title . [About]
        if {$testConfig(VERBOSE) >= 20} {
            puts "  [About]"
            puts "---------------------starting-------------------------------"
        }
    }
 
    set code [catch {
        Test
    } error]
 
    if $code {
        if {$code == 1234} {
            puts -nonewline "Test $f is aborted"
        } else {
            puts -nonewline "Test $f is aborted unexpectedly"
        }
        if {[info exists errorInfo] && ![tixStrEq $errorInfo ""]} {
            puts " by the following error\n$errorInfo"
        } else {
            puts "."
        }
    }
    Done
}
 
# fileList: name of the file that contains a list of test targets
# type: "dir" or "script"
#
proc Driver:GetTargets {fileList type} {
    set fd [open $fileList {RDONLY}]
    set data {}
 
    while {![eof $fd]} {
        set line [string trim [gets $fd]]
        if [regexp ^# $line] {
            continue
        }
        append data $line\n
    }
 
    close $fd
    set files {}
 
    foreach item $data {
        set takeit 1
 
        foreach cond [lrange $item 1 end] {
            set inverse 0
            set cond [string trim $cond]
            if {[string index $cond 0] == "!"} {
                set cond [string range $cond 1 end]
                set inverse 1
            }
 
            set true 1
            case [lindex $cond 0] {
                c {
                    set cmd [lindex $cond 1]
                    if {[info command $cmd] != $cmd} {
                        if ![auto_load $cmd] {
                            set true 0
                        }
                    }
                }
                i {
                    if {[lsearch [image types] [lindex $cond 1]] == -1} {
                        set true 0
                    }
                }
                v {
                    set var [lindex $cond 1]
                    if ![uplevel #0 info exists [list $var]] {
                        set true 0
                    }
                }
                default {
                    # must be an expression
                    #
                    if ![uplevel #0 expr [list $cond]] {
                        set true 0
                    }
                }
            }
 
            if {$inverse} {
                set true [expr !$true]
            }
            if {!$true} {
                set takeit 0
                break
            }
        }
 
        if {$takeit} {
            lappend files [lindex $item 0]
        }
    }
    return $files
}
 
proc Driver:Main {} {
    global argv env
 
    if [tixStrEq $argv "dont"] {
        return
    }
 
    set argvfiles  $argv
    set env(WAITTIME) 200
 
    set errCount 0
 
    set PWD [pwd]
    if {$argvfiles == {}} {
        set argvfiles [Driver:GetTargets files dir]
    }
 
    foreach f $argvfiles {
        Driver:Execute $f
        cd $PWD
    }
}
 
proc Driver:Execute {f} {
    global testConfig
 
    if [file isdir $f] {
        raise .
        set dir $f
 
        if {$testConfig(VERBOSE) >= 20} {
            puts "Entering directory $dir ..."
        }
        cd $dir
 
        if [file exists pkginit.tcl] {
            # call the package initialization file, which is
            # something specific to the files in this directory
            #
            source pkginit.tcl
        }
        foreach f [Driver:GetTargets files script] {
            set _PWD [pwd]
            Driver:Test $dir/$f $f
            cd $_PWD
        }
        if {$testConfig(VERBOSE) >= 20} {
            puts "Leaving directory $dir ..."
        }
    } else {
        set dir [file dirname $f]
        if {$dir != {}} {
            if {$testConfig(VERBOSE) >= 20} {
                puts "Entering directory $dir ..."
            }
            cd $dir
            if [file exists pkginit.tcl] {
                # call the package initialization file, which is
                # something specific to the files in this directory
                #
                source pkginit.tcl
            }
            set f [file tail $f]
        }
        set _PWD [pwd]
        Driver:Test $f $f
        cd $_PWD
 
        if {$testConfig(VERBOSE) >= 20} {
            puts "Leaving directory $dir ..."
        }
    }
}
 
if [tixStrEq [tix platform] "windows"] {
    # The following are a bunch of useful functions to make it more convenient
    # to run the tests on Windows inside the Tix console window.
    #
 
    # do --
    #
    #   Execute a test.
    #
    proc do {f} {
        set PWD [pwd]
        Driver:Execute $f
        cd $PWD
        puts "% "
    }
 
    # rnew --
    #
    #   Read in all the files in the Tix library path that has been modified.
    #
    proc rnew {} {
        global lastModified filesPatterns
        foreach file [eval glob $filesPatterns] {
            set mtime [file mtime $file]
            if {$lastModified < $mtime} {
                set lastModified $mtime
                puts "sourcing $file"
                uplevel #0 source [list $file]
            }
        }
    }
 
    # pk --
    #
    #   pack widgets filled and expanded
    proc pk {args} {
        eval pack $args -expand yes -fill both
    }
 
    # Initialize the lastModified so that rnew only loads in newly modified
    # files
    #
    set filesPatterns {../library/*.tcl Driver.tcl library/*.tcl}
    set lastModified 0
    foreach file [eval glob $filesPatterns] {
        set mtime [file mtime $file]
        if {$lastModified < $mtime} {
            set lastModified $mtime
        }
    }
 
    proc ei {} {
        global errorInfo
        puts $errorInfo
    }
}
 
 
uplevel #0 source library/TestLib.tcl
uplevel #0 source library/CaseData.tcl
wm title . "Test-driving Tix"
Driver:Main
 
puts "$testConfig(errCount) error(s) found"
 
if {[tix platform] != "windows"} {
    destroy .
    catch {
        update
    }
    exit 0
} else {
    puts -nonewline "type \"exit\" to quit the test\n% "
    proc q {} {
        exit
    }
}
 

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tix/] [tests/] [Driver.tcl] - Blame information for rev 1778

Line No.	Rev	Author	Line
1	578	markom	`# This is the "Test Driver" program that sources in each test script. It`
2			`# must be invoked by the test/Test.tcl program (in Unix) or by a properly`
3			`# configured wish.exe program (in Wondows).`
4			`#`
5
6			`catch {`
7			`cd [file dirname [info script]]`
8			`}`
9
10			`set oldglobals {}`
11			`set oldglobals [info globals]`
12
13			`# Some parts of the test execute tests for a specific platform. The variable`
14			`# tixPriv(test:platform) controls the tests for which platform should`
15			`# be executed. This can be controlled by the TEST_PLATFORM environment`
16			`# variable`
17
18			`set tixPriv(test:platform) unix`
19			`if [info exists tcl_platform(platform)] {`
20			`if {$tcl_platform(platform) == "windows"} {`
21			`set tixPriv(test:platform) windows`
22			`}`
23			`}`
24
25			`if [info exists env(TEST_PLATFORM)] {`
26			`set tixPriv(test:platform) $env(TEST_PLATFORM)`
27			`}`
28
29			`global testConfig`
30			`if {![info exists tix]} {`
31			`if ![info exists tcl_platform(platform)] {`
32			`puts "ERROR: this version of wish doesn't support dynamic loading"`
33			`exit -1`
34			`}`
35
36			`# This must have been executed by a plain wish expecting to`
37			`# dynamic load Tix.`
38
39			`puts -nonewline "trying to dynamically load Tix ... "`
40
41			`global tk_version`
42			`if {$tcl_platform(platform) == "unix"} {`
43			`case $tk_version {`
44			`4.1 {`
45			`set testConfig(dynlib) \`
46			`../unix/tk4.1/libtix4.1.4.1[info sharedlibextension]`
47			`}`
48			`4.2 {`
49			`set testConfig(dynlib) \`
50			`../unix/tk4.2/libtix4.1.4.2[info sharedlibextension]`
51			`}`
52			`}`
53			`} else {`
54			`case $tk_version {`
55			`4.1 {`
56			`set testConfig(dynlib) ..\\win\\tix41.dll`
57			`}`
58			`4.2 {`
59			`set testConfig(dynlib) ..\\win\\tix41.dll`
60			`}`
61			`}`
62			`}`
63
64			`if [info exists testConfig(dynlib)] {`
65			`load $testConfig(dynlib) Tix`
66			`}`
67
68			`if {[info exists tix]} {`
69			`puts succeeded`
70			`} else {`
71			`puts failed`
72			`exit`
73			`}`
74			`} else {`
75			`set testConfig(dynlib) ""`
76			`}`
77
78			`proc Driver:Test {name f} {`
79			`global oldglobals errorInfo testConfig`
80
81			`foreach w [winfo children .] {`
82			`if [string comp .__top $w] {`
83			`destroy $w`
84			`}`
85			`}`
86
87			`foreach g [info globals] {`
88			`if {[lsearch $oldglobals $g] == -1} {`
89			`# uplevel #0 unset $g`
90			`}`
91			`}`
92
93			`if {$testConfig(VERBOSE) >= 20} {`
94			`puts ------------------------------------------------------------`
95			`puts "Loading script $name"`
96			`} else {`
97			`puts $name`
98			`}`
99
100			`update`
101			`uplevel #0 source $f`
102			`Event-Initialize`
103			`catch {`
104			`wm title . [About]`
105			`if {$testConfig(VERBOSE) >= 20} {`
106			`puts " [About]"`
107			`puts "---------------------starting-------------------------------"`
108			`}`
109			`}`
110
111			`set code [catch {`
112			`Test`
113			`} error]`
114
115			`if $code {`
116			`if {$code == 1234} {`
117			`puts -nonewline "Test $f is aborted"`
118			`} else {`
119			`puts -nonewline "Test $f is aborted unexpectedly"`
120			`}`
121			`if {[info exists errorInfo] && ![tixStrEq $errorInfo ""]} {`
122			`puts " by the following error\n$errorInfo"`
123			`} else {`
124			`puts "."`
125			`}`
126			`}`
127			`Done`
128			`}`
129
130			`# fileList: name of the file that contains a list of test targets`
131			`# type: "dir" or "script"`
132			`#`
133			`proc Driver:GetTargets {fileList type} {`
134			`set fd [open $fileList {RDONLY}]`
135			`set data {}`
136
137			`while {![eof $fd]} {`
138			`set line [string trim [gets $fd]]`
139			`if [regexp ^# $line] {`
140			`continue`
141			`}`
142			`append data $line\n`
143			`}`
144
145			`close $fd`
146			`set files {}`
147
148			`foreach item $data {`
149			`set takeit 1`
150
151			`foreach cond [lrange $item 1 end] {`
152			`set inverse 0`
153			`set cond [string trim $cond]`
154			`if {[string index $cond 0] == "!"} {`
155			`set cond [string range $cond 1 end]`
156			`set inverse 1`
157			`}`
158
159			`set true 1`
160			`case [lindex $cond 0] {`
161			`c {`
162			`set cmd [lindex $cond 1]`
163			`if {[info command $cmd] != $cmd} {`
164			`if ![auto_load $cmd] {`
165			`set true 0`
166			`}`
167			`}`
168			`}`
169			`i {`
170			`if {[lsearch [image types] [lindex $cond 1]] == -1} {`
171			`set true 0`
172			`}`
173			`}`
174			`v {`
175			`set var [lindex $cond 1]`
176			`if ![uplevel #0 info exists [list $var]] {`
177			`set true 0`
178			`}`
179			`}`
180			`default {`
181			`# must be an expression`
182			`#`
183			`if ![uplevel #0 expr [list $cond]] {`
184			`set true 0`
185			`}`
186			`}`
187			`}`
188
189			`if {$inverse} {`
190			`set true [expr !$true]`
191			`}`
192			`if {!$true} {`
193			`set takeit 0`
194			`break`
195			`}`
196			`}`
197
198			`if {$takeit} {`
199			`lappend files [lindex $item 0]`
200			`}`
201			`}`
202			`return $files`
203			`}`
204
205			`proc Driver:Main {} {`
206			`global argv env`
207
208			`if [tixStrEq $argv "dont"] {`
209			`return`
210			`}`
211
212			`set argvfiles $argv`
213			`set env(WAITTIME) 200`
214
215			`set errCount 0`
216
217			`set PWD [pwd]`
218			`if {$argvfiles == {}} {`
219			`set argvfiles [Driver:GetTargets files dir]`
220			`}`
221
222			`foreach f $argvfiles {`
223			`Driver:Execute $f`
224			`cd $PWD`
225			`}`
226			`}`
227
228			`proc Driver:Execute {f} {`
229			`global testConfig`
230
231			`if [file isdir $f] {`
232			`raise .`
233			`set dir $f`
234
235			`if {$testConfig(VERBOSE) >= 20} {`
236			`puts "Entering directory $dir ..."`
237			`}`
238			`cd $dir`
239
240			`if [file exists pkginit.tcl] {`
241			`# call the package initialization file, which is`
242			`# something specific to the files in this directory`
243			`#`
244			`source pkginit.tcl`
245			`}`
246			`foreach f [Driver:GetTargets files script] {`
247			`set _PWD [pwd]`
248			`Driver:Test $dir/$f $f`
249			`cd $_PWD`
250			`}`
251			`if {$testConfig(VERBOSE) >= 20} {`
252			`puts "Leaving directory $dir ..."`
253			`}`
254			`} else {`
255			`set dir [file dirname $f]`
256			`if {$dir != {}} {`
257			`if {$testConfig(VERBOSE) >= 20} {`
258			`puts "Entering directory $dir ..."`
259			`}`
260			`cd $dir`
261			`if [file exists pkginit.tcl] {`
262			`# call the package initialization file, which is`
263			`# something specific to the files in this directory`
264			`#`
265			`source pkginit.tcl`
266			`}`
267			`set f [file tail $f]`
268			`}`
269			`set _PWD [pwd]`
270			`Driver:Test $f $f`
271			`cd $_PWD`
272
273			`if {$testConfig(VERBOSE) >= 20} {`
274			`puts "Leaving directory $dir ..."`
275			`}`
276			`}`
277			`}`
278
279			`if [tixStrEq [tix platform] "windows"] {`
280			`# The following are a bunch of useful functions to make it more convenient`
281			`# to run the tests on Windows inside the Tix console window.`
282			`#`
283
284			`# do --`
285			`#`
286			`# Execute a test.`
287			`#`
288			`proc do {f} {`
289			`set PWD [pwd]`
290			`Driver:Execute $f`
291			`cd $PWD`
292			`puts "% "`
293			`}`
294
295			`# rnew --`
296			`#`
297			`# Read in all the files in the Tix library path that has been modified.`
298			`#`
299			`proc rnew {} {`
300			`global lastModified filesPatterns`
301			`foreach file [eval glob $filesPatterns] {`
302			`set mtime [file mtime $file]`
303			`if {$lastModified < $mtime} {`
304			`set lastModified $mtime`
305			`puts "sourcing $file"`
306			`uplevel #0 source [list $file]`
307			`}`
308			`}`
309			`}`
310
311			`# pk --`
312			`#`
313			`# pack widgets filled and expanded`
314			`proc pk {args} {`
315			`eval pack $args -expand yes -fill both`
316			`}`
317
318			`# Initialize the lastModified so that rnew only loads in newly modified`
319			`# files`
320			`#`
321			`set filesPatterns {../library/.tcl Driver.tcl library/.tcl}`
322			`set lastModified 0`
323			`foreach file [eval glob $filesPatterns] {`
324			`set mtime [file mtime $file]`
325			`if {$lastModified < $mtime} {`
326			`set lastModified $mtime`
327			`}`
328			`}`
329
330			`proc ei {} {`
331			`global errorInfo`
332			`puts $errorInfo`
333			`}`
334			`}`
335
336
337			`uplevel #0 source library/TestLib.tcl`
338			`uplevel #0 source library/CaseData.tcl`
339			`wm title . "Test-driving Tix"`
340			`Driver:Main`
341
342			`puts "$testConfig(errCount) error(s) found"`
343
344			`if {[tix platform] != "windows"} {`
345			`destroy .`
346			`catch {`
347			`update`
348			`}`
349			`exit 0`
350			`} else {`
351			`puts -nonewline "type \"exit\" to quit the test\n% "`
352			`proc q {} {`
353			`exit`
354			`}`
355			`}`
356