Viewing file:  constraints.tcl (12.05 KB) -rw-r--r--
Select action/file-type:
 (+) |  (+) |  (+) | Code (+) | Session (+) |  (+) | SDB (+) |  (+) |  (+) |  (+) |  (+) |  (+) |
# constraints.tcl --
# Interface for constraints.
# $Id$
# tcltest::constraints::exists --
#
# Check to see whether a given constraint exists.
#
# Arguments:
# constraint.
#
# Side Effects:
# None.
#
# Results:
# 1 if constraint exists, 0 if it does not.
proc tcltest::constraints::exists {constraint} {
return [info exists vars::$constraint]
}
# tcltest::constraints::cset --
#
# Set constraint or check its value.
#
# Arguments:
# constraint - constraint to set or check.
# value - optional argument.
#
# Side Effects:
# Sets constraint if value is given.
#
# Results:
# None.
proc tcltest::constraints::cset {args} {
set constraint [lindex $args 0]
if { [llength $args] == 1 } {
if { ! [info exists vars::$constraint] } {
return 0
} else {
return [set vars::$constraint]
}
} else {
set vars::$constraint [lindex $args 1]
}
}
proc tcltest::constraints::initconst {constraint} {
set retval 0
if { [catch {
set retval [tcltest::testConstraint $constraint \
[eval [ConstraintInitializer $constraint]]]
} err] } {
puts "DIO CAGNOLINO $err"
}
return $retval
}
# tcltest::constraints::getlist --
#
# Gets a list of all constraints.
#
# Arguments:
# None.
#
# Side Effects:
# None.
#
# Results:
# List of all constraints.
proc tcltest::constraints::getlist {} {
set reslist {}
foreach v [info vars vars::*] {
lappend reslist [namespace tail $v]
}
return $reslist
}
# tcltest::constraints::incrskippedbecause --
#
# Increments the variable used to track how many tests were
# skipped because of a particular constraint.
#
# Arguments:
# constraint The name of the constraint to be modified
#
# Results:
# Modifies tcltest::skippedBecause; sets the variable to 1 if
# didn't previously exist - otherwise, it just increments it.
#
# Side effects:
# None.
proc tcltest::constraints::incrskippedbecause { constraint {value 1} } {
variable skippedBecause
if {[info exists skippedBecause($constraint)]} {
incr skippedBecause($constraint) $value
} else {
set skippedBecause($constraint) $value
}
return
}
# tcltest::constraints::skippedlist --
#
# Get list of all constraints that kept tests from running..
#
# Arguments:
# None.
#
# Side Effects:
# None.
#
# Results:
# A list of constraints.
proc tcltest::constraints::skippedlist {} {
variable skippedBecause
return [array names skippedBecause]
}
# tcltest::constraints::getskipped --
#
# Gets number of tests skipped because of a particular
# constraint.
#
# Arguments:
# constraint - constraint.
#
# Side Effects:
# None.
#
# Results:
# Integer number of tests skipped.
proc tcltest::constraints::getskipped { constraint } {
variable skippedBecause
return $skippedBecause($constraint)
}
# tcltest::constraints::clearskippedlist --
#
# Clears the list of skipped constraints.
#
# Arguments:
# None.
#
# Side Effects:
# Resets the list of skipped constraints.
#
# Results:
# None.
proc tcltest::constraints::clearskippedlist {} {
variable skippedBecause
array unset skippedBecause
array set skippedBecause {}
}
# tcltest::constraints::checktest --
#
# Check test to see if the constraints are satisfied. Note that
# 'constraintsvar' has to use upvar to reference the real
# variable, because these checks actually change the
# constraints. Something to fix in the future if possible.
#
# Arguments:
# name - test name.
# constraintsvar - constraint to check against.
#
# Side Effects:
# None.
#
# Results:
# None.
proc tcltest::constraints::checktest {name constraintsvar} {
upvar $constraintsvar constraints
set doTest 0
# I don't agree with this. I think that a constraint should
# either be an artificial construct such as unix || pc, OR it
# should be a plain old Tcl expression, possibly to be evaluated
# in its own namespace. FIXME at some later date when we can toss
# this stuff out. -davidw
if {[string match {*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
catch {set doTest [uplevel \#0 expr $constraints]}
} elseif {[regexp {[^.a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
# something like {a || b} should be turned into
# $testConstraints(a) || $testConstraints(b).
regsub -all {[.\w]+} $constraints {$&} c
catch {set doTest [namespace eval vars [list expr $c]]}
} elseif {![catch {llength $constraints}]} {
# just simple constraints such as {unixOnly fonts}.
set doTest 1
foreach constraint $constraints {
if { ! [cset $constraint] } {
set doTest 0
# store the constraint that kept the test from
# running
set constraints $constraint
break
}
}
}
# Return the opposite of doTest
return [expr {$doTest ? 0 : 1}]
}
# tcltest::constraints::ConstraintInitializer --
#
# Get or set a script that when evaluated in the tcltest namespace
# will return a boolean value with which to initialize the
# associated constraint.
#
# Arguments:
# constraint - name of the constraint initialized by the script
# script - the initializer script
#
# Results
# boolean value of the constraint - enabled or disabled
#
# Side effects:
# Constraint is initialized for future reference by [test]
proc tcltest::constraints::ConstraintInitializer {constraint {script ""}} {
variable ConstraintInitializer
# Check for boolean values
if {![info complete $script]} {
return -code error "ConstraintInitializer must be complete script"
}
set retval [namespace eval ::tcltest $script]
cset $constraint $retval
}
# tcltest::constraints::DefineConstraintInitializers --
#
# Set up the initial constraints (such as unix, pc, and so on).
#
# Arguments:
# None.
#
# Side Effects:
# Creates a number of constraints.
#
# Results:
# None.
proc tcltest::constraints::DefineConstraintInitializers {} {
ConstraintInitializer singleTestInterp {tcltest::singleProcess}
# All the 'pc' constraints are here for backward compatibility and
# are not documented. They have been replaced with equivalent 'win'
# constraints.
ConstraintInitializer unixOnly \
{string equal $::tcl_platform(platform) unix}
ConstraintInitializer macOnly \
{string equal $::tcl_platform(platform) macintosh}
ConstraintInitializer pcOnly \
{string equal $::tcl_platform(platform) windows}
ConstraintInitializer winOnly \
{string equal $::tcl_platform(platform) windows}
ConstraintInitializer unix {tcltest::testConstraint unixOnly}
ConstraintInitializer mac {tcltest::testConstraint macOnly}
ConstraintInitializer pc {tcltest::testConstraint pcOnly}
ConstraintInitializer win {tcltest::testConstraint winOnly}
ConstraintInitializer unixOrPc \
{expr {[tcltest::testConstraint unix] || [tcltest::testConstraint pc]}}
ConstraintInitializer macOrPc \
{expr {[tcltest::testConstraint mac] || [tcltest::testConstraint pc]}}
ConstraintInitializer unixOrWin \
{expr {[tcltest::testConstraint unix] || [tcltest::testConstraint win]}}
ConstraintInitializer macOrWin \
{expr {[tcltest::testConstraint mac] || [tcltest::testConstraint win]}}
ConstraintInitializer macOrUnix \
{expr {[tcltest::testConstraint mac] || [tcltest::testConstraint unix]}}
ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
# The following Constraints switches are used to mark tests that
# should work, but have been temporarily disabled on certain
# platforms because they don't and we haven't gotten around to
# fixing the underlying problem.
ConstraintInitializer tempNotPc {expr {![tcltest::testConstraint pc]}}
ConstraintInitializer tempNotWin {expr {![tcltest::testConstraint win]}}
ConstraintInitializer tempNotMac {expr {![tcltest::testConstraint mac]}}
ConstraintInitializer tempNotUnix {expr {![tcltest::testConstraint unix]}}
# The following Constraints switches are used to mark tests that
# crash on certain platforms, so that they can be reactivated again
# when the underlying problem is fixed.
ConstraintInitializer pcCrash {expr {![tcltest::testConstraint pc]}}
ConstraintInitializer winCrash {expr {![tcltest::testConstraint win]}}
ConstraintInitializer macCrash {expr {![tcltest::testConstraint mac]}}
ConstraintInitializer unixCrash {expr {![tcltest::testConstraint unix]}}
# Skip empty tests
ConstraintInitializer emptyTest {format 0}
# By default, tests that expose known bugs are skipped.
ConstraintInitializer knownBug {format 0}
# By default, non-portable tests are skipped.
ConstraintInitializer nonPortable {format 0}
# Some tests require user interaction.
ConstraintInitializer userInteraction {format 0}
# Some tests must be skipped if the interpreter is not in
# interactive mode
ConstraintInitializer interactive \
{expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
# Some tests can only be run if the installation came from a CD
# image instead of a web image. Some tests must be skipped if you
# are running as root on Unix. Other tests can only be run if you
# are running as root on Unix.
ConstraintInitializer root {expr \
{[string equal unix $::tcl_platform(platform)]
&& ([string equal root $::tcl_platform(user)]
|| [string equal "" $::tcl_platform(user)])}}
ConstraintInitializer notRoot {expr {![tcltest::testConstraint root]}}
# Set nonBlockFiles constraint: 1 means this platform supports
# setting files into nonblocking mode.
ConstraintInitializer nonBlockFiles {
set code [expr {[catch {set f [open defs r]}]
|| [catch {fconfigure $f -blocking off}]}]
catch {close $f}
set code
}
# Set asyncPipeClose constraint: 1 means this platform supports
# async flush and async close on a pipe.
#
# Test for SCO Unix - cannot run async flushing tests because a
# potential problem with select is apparently interfering.
# (Mark Diekhans).
ConstraintInitializer asyncPipeClose {expr {
!([string equal unix $::tcl_platform(platform)]
&& ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
# Test to see if we have a broken version of sprintf with respect
# to the "e" format of floating-point numbers.
ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
# Test to see if execed commands such as cat, echo, rm and so forth
# are present on this machine.
ConstraintInitializer unixExecs {
set code 1
if {[string equal macintosh $::tcl_platform(platform)]} {
set code 0
}
if {[string equal windows $::tcl_platform(platform)]} {
if {[catch {
set file _tcl_test_remove_me.txt
makeFile {hello} $file
}]} {
set code 0
} elseif {
[catch {exec cat $file}] ||
[catch {exec echo hello}] ||
[catch {exec sh -c echo hello}] ||
[catch {exec wc $file}] ||
[catch {exec sleep 1}] ||
[catch {exec echo abc > $file}] ||
[catch {exec chmod 644 $file}] ||
[catch {exec rm $file}] ||
[llength [auto_execok mkdir]] == 0 ||
[llength [auto_execok fgrep]] == 0 ||
[llength [auto_execok grep]] == 0 ||
[llength [auto_execok ps]] == 0
} {
set code 0
}
removeFile $file
}
set code
}
ConstraintInitializer stdio {
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
set code 1
}
}
}
set code
}
# Deliberately call socket with the wrong number of arguments. The
# error message you get will indicate whether sockets are available
# on this system.
ConstraintInitializer socket {
catch {socket} msg
string compare $msg "sockets are not available on this system"
}
# Check for internationalization
ConstraintInitializer hasIsoLocale {
if {[llength [info commands testlocale]] == 0} {
set code 0
} else {
set code [string length [SetIso8859_1_Locale]]
RestoreLocale
}
set code
}
}
|