Import Tix 8.4.3.5 (as of svn r86089)
This commit is contained in:
Zachary Ware
317
tests/Driver.tcl
Normal file
317
tests/Driver.tcl
Normal file
@@ -0,0 +1,317 @@
|
||||
# -*- 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
|
||||
Reference in New Issue
Block a user