318 lines
8.5 KiB
Tcl
318 lines
8.5 KiB
Tcl
# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
|
|
#
|
|
# $Id: Driver.tcl,v 1.4 2002/12/15 04:21:53 idiscovery Exp $
|
|
#
|
|
# This is the "Test Driver" program that sources in each test script. It
|
|
# is invoked by tests/Test.tcl or by "make tests" in unix/tk8.0 (in
|
|
# Unix) or by a properly configured wish.exe program (in Windows).
|
|
#
|
|
catch {
|
|
cd [file dirname [info script]]
|
|
}
|
|
|
|
# Some parts of the test 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]} {
|
|
puts "TIX INITIALIZATION ERROR: tix not found"
|
|
exit -1
|
|
}
|
|
set testConfig(dynlib) ""
|
|
|
|
# The following global arrays are used by these tests:
|
|
#
|
|
# testConfig
|
|
# dynlib, VERBOSE, errCount
|
|
# tix:
|
|
# tixPriv:
|
|
# test:platform
|
|
# testapp
|
|
# X, Y
|
|
|
|
|
|
# --------------------------------------------------------- Driver:Test
|
|
#
|
|
proc Driver:Test {name f} {
|
|
global errorInfo testConfig
|
|
|
|
# destroy all child windows other than '.__top'
|
|
foreach w [winfo children .] {
|
|
if [string comp .__top $w] {
|
|
destroy $w
|
|
}
|
|
}
|
|
|
|
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
|
|
}; # Driver:Test
|
|
|
|
# --------------------------------------------------- Driver:GetTargets
|
|
#
|
|
# 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
|
|
}; # Driver:GetTargets
|
|
|
|
# --------------------------------------------------------- Driver:Main
|
|
#
|
|
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
|
|
}
|
|
}; # Driver:Main
|
|
|
|
# ------------------------------------------------------ Driver:Execute
|
|
#
|
|
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 ..."
|
|
}
|
|
}
|
|
}; # Driver:Execute
|
|
|
|
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 have
|
|
# 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 'lastModified' so that rnew loads only 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
|
|
}
|
|
}
|
|
|
|
puts "tcl_version = $tcl_version, tcl_patchLevel = $tcl_patchLevel"
|
|
puts "tcl_precision = $tcl_precision, tcl_library = $tcl_library"
|
|
puts "tk_version = $tk_version, tk_patchLevel = $tk_patchLevel"
|
|
puts "tix_version = $tix_version, tix_patchLevel = $tix_patchLevel"
|
|
puts "tix_release = $tix_release"
|
|
puts "tcl_platform = '[array get tcl_platform]'"
|
|
|
|
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"
|
|
|
|
destroy .
|
|
catch {update}
|
|
exit 0
|