aboutsummaryrefslogtreecommitdiff
path: root/contrib/bluegnu2.0.3/lib/testSessionFramework.itcl
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/bluegnu2.0.3/lib/testSessionFramework.itcl')
-rw-r--r--contrib/bluegnu2.0.3/lib/testSessionFramework.itcl1386
1 files changed, 0 insertions, 1386 deletions
diff --git a/contrib/bluegnu2.0.3/lib/testSessionFramework.itcl b/contrib/bluegnu2.0.3/lib/testSessionFramework.itcl
deleted file mode 100644
index 7f96880..0000000
--- a/contrib/bluegnu2.0.3/lib/testSessionFramework.itcl
+++ /dev/null
@@ -1,1386 +0,0 @@
-#
-#
-#
-#
-# unknown -- called by expect if a proc is called that doesn't exist
-#
-
-# Set auto_load to take BLUEGNULIB first on search path
-#
-set auto_path "$env(BLUEGNULIB) $auto_path"
-
-# find tclIndex file in the test suite directory structure
-# $env(TESTSUITEROOT) and in the path up to the root
-#
-if {! [info exists env(TESTSUITEROOT)]} {
- set env(TESTSUITEROOT) [exec /bin/sh -c pwd]
-}
-set PWD $env(TESTSUITEROOT)
-
-if {[info exists env(TESTSETS)]} {
- if {[lsearch -exact [split $env(TESTSETS) ":"] $PWD] < 0} {
- set env(TESTSETS) $PWD:$env(TESTSETS)
- }
-} else {
- set env(TESTSETS) $PWD
-}
-cd $PWD
-
-
-# First thing to do is calculate the verbose level and the debug flag
-# as well as the definition of the associated procedures:
-# verbose and debug.
-#
-# Check the Debug level
-if [info exists env(DEBUG)] {
- switch -regexp [string toupper $env(DEBUG)] {
- 1 - ^T(R(U(E)?)?)?$ - ^Y(E(S)?)?$ {
- set bDebug 1
- }
- default {
- set bDebug 0
- }
- }
-} else {
- set bDebug 0
-}
-
-# Calculate verbose level
-# Complete a first path over the argument list
-# Calculate the Verbose Level
-set verbose 0
-foreach __arg $argv {
- switch -regexp -- $__arg {
- {^-[-]?v(e(r(b(o(s(e)?)?)?)?)?)?$} {
- incr verbose
- }
- default {
- lappend __lArgs $__arg
- }
- }
-}
-if {[catch {set argv $__lArgs}]} {
- set argv {}
-}
-
-# Define the procedures: verbose & debug
-#
-# verbose [-n] [-log] [--] message [level]
-#
-# Print MESSAGE if the verbose level is >= LEVEL.
-# The default value of LEVEL is 1.
-# "-n" says to not print a trailing newline.
-# "-log" says to add the text to the log file even if it won't be printed.
-# Note that the apparent behaviour of `send_user' dictates that if the message
-# is printed it is also added to the log file.
-# Use "--" if MESSAGE begins with "-".
-#
-# This is defined here rather than in framework.exp so we can use it
-# while still loading in the support files.
-#
-proc verbose {args} {
- debug {======= verbose $args} 3
- global verbose
-
- set newline 1
- set logfile 0
-
- set i 0
- if {[string index [lindex $args 0] 0] == "-"} {
- for { set i 0 } { $i < [llength $args] } { incr i } {
- if { [lindex $args $i] == "--" } {
- incr i
- break
- } elseif { [lindex $args $i] == "-n" } {
- set newline 0
- } elseif { [lindex $args $i] == "-log" } {
- set logfile 1
- } elseif { [string index [lindex $args $i] 0] == "-" } {
- return [::BlueGnu::clone_output "ERROR: verbose:\
- illegal argument: [lindex $args $i]"]
- } else {
- break
- }
- }
- }
- if {[llength $args] == $i} {
- return [::BlueGnu::clone_output "ERROR: verbose: nothing to print"]
- }
-
-
- set level 1
- if {[llength $args] == $i + 2} {
- if [catch {set level [expr [lindex $args [expr $i+1]]]} szErrMsg] {
- return [::BlueGnu::clone_output "ERROR: verbose: level number\
- >$szErrMsg<"]
- }
- } elseif {[llength $args] > $i + 2} {
- return [::BlueGnu::clone_output "ERROR: verbose: Too many arguments"]
- }
- set message [lindex $args $i]
-
- if {$level <= $verbose} {
- # There is no need for the "--" argument here, but play it safe.
- # We assume send_user also sends the text to the log file (which
- # appears to be the case though the docs aren't clear on this).
- if 0 {
- if {[string compare \
- [namespace eval ::BlueGnu \
- {set ::BlueGnu::sum_file}] stdout] != 0} {
- set szCmd [list uplevel puts [namespace eval ::BlueGnu \
- {set ::BlueGnu::sum_file}]]
- lappend szCmd "\"$message\""
- debug {==## 1 >$szCmd<} 9
- if {[catch {eval $szCmd}]} {
- puts [namespace eval ::BlueGnu \
- {set ::BlueGnu::sum_file}] $message
- }
- }
- }
- if [catch {set message \
- "[uplevel set __szTmp \"$message\"]"} szErrMsg] {
- set message "$message == ERROR: >$szErrMsg<"
- }
- if {$newline} {
- #append message "\n"
- }
- debug {$message} 0
- return [::BlueGnu::clone_output "$message"]
- } elseif {$logfile} {
- if [catch {set message \
- "[uplevel set __szTmp \"$message\"]"} szErrMsg] {
- set message "$message == ERROR: >$szErrMsg<"
- }
- if {$newline} {
- append message "\n"
- }
- debug {$message} 0
- return [send_log $message]
- }
- return ""
-}
-
-if {$bDebug} {
- proc debug {text {level 1}} {
- global verbose
-
- if {$level <= $verbose} {
- set szCmd [list uplevel ::BlueGnu::clone_output]
- set szA $level; set iMax [uplevel info level]
- for {set i 0} {$i < $iMax} \
- {incr i} {append szA ">"}
- lappend szCmd "\"$szA$text\""
- eval $szCmd
- }
- }
-} else {
- proc debug {text {level 1}} {
- }
-}
-
-# This procedure will find a file in the directory structure
-# any where below the current working directory
-# any where on the search path
-# or up the directory tree
-#
-proc locateFile {szFileName {szSubDirectory "."}} {
- debug {======= locateFile $szFileName $szSubDirectory} 3
- global env
- # remove a trailing "/" from sub directory name
- regexp {(.*)/$} $szSubDirectory dummy szSubDirectory
-
- set newList {}
- set searchList {.}
- set tmpDir [pwd]
- while {[string compare [set dir [file dirname $tmpDir]] "/"] != 0} {
- lappend searchList $dir
- set tmpDir $dir
- }
- foreach dir [split $env(TESTSETS) ":"] {
- lappend searchList $dir
- }
- foreach dirList $searchList {
- foreach test [searchForFile $szFileName $dirList $szSubDirectory] {
- # only files that are readable and
- # not a directory, symbolic link or device
- # are added to the list
- if {[file isfile $test] && [file readable $test]} {
- # add only if not already exists in list
- if {[lsearch -exact $newList $test] < 0} {
- lappend newList $test
- }
- }
- }
- }
- debug {======= returning newList: >$newList<} 4
- return $newList
-}
-
-proc locateDir {szFileName {szSubDirectory "."}} {
- debug {======= locateDir $szFileName $szSubDirectory} 3
- global env
- # remove a trailing "/" from sub directory name
- regexp {(.*)/$} $szSubDirectory dummy szSubDirectory
-
- set newList {}
- set searchList {.}
- set tmpDir [pwd]
- while {[string compare [set dir [file dirname $tmpDir]] "/"] != 0} {
- lappend searchList $dir
- set tmpDir $dir
- }
- foreach dir [split $env(TESTSETS) ":"] {
- lappend searchList $dir
- }
- foreach dirList $searchList {
- foreach test [searchForFile $szFileName $dirList $szSubDirectory] {
- # only files that are directories
- # are added to the list
- if {[file isdirectory $test]} {
- # add only if not already exists in list
- if {[lsearch -exact $newList $test] < 0} {
- lappend newList $test
- }
- }
- }
- }
- debug {======= returning newList: >$newList<} 4
- return $newList
-}
-
-proc searchForFile {szFileName dirList szSubDirectory} {
- debug {======= searchForFile $szFileName $dirList $szSubDirectory} 3
- # find sub directory in or below the current working directory
- set szDirSrc ""
- foreach file [file split $szSubDirectory] {
- if {[string compare $file "."] == 0} {
- if {! [info exists newList]} {
- set newList {}
- }
- continue
- } else {
- foreach dir $dirList {
- catch {unset newList}
- foreach newDir [findFile $dir $file] {
- lappend newList $newDir
- }
- }
- }
- if {[catch {set dirList $newList}]} {
- set dirList {}
- }
- }
- debug { dirList = >$dirList<} 4
- set fileList {}
- foreach dir $dirList {
- set newList [findFile $dir $szFileName]
- if {[llength $newList] > 0} {
- set fileList [concat $fileList $newList]
- }
- }
- debug { fileList = >$fileList<} 4
- if {[llength $fileList] != 0} {
- # NO test found, next step in searching
- #return $fileList
- }
-
- set newList {}
- set PWD [pwd]
- foreach dir $fileList {
- debug { dir = >$dir<} 4
- cd [file dirname $dir]
- lappend newList "[pwd]/[file tail $dir]"
- cd $PWD
- }
-
- debug { newList = >$newList<} 4
- return $newList
-}
-
-proc findFile {szDirectory szFileName} {
- global locatedFile env
-
- debug {======= findFile $szDirectory $szFileName} 3
- if {! [info exists locatedFile($szDirectory/$szFileName)]} {
- if {[file readable $szDirectory/$szFileName]} {
- set locatedFile($szDirectory/$szFileName) $szDirectory/$szFileName
- } else {
- if {$szDirectory == "." || \
- [lsearch -exact [split $env(TESTSETS) ":"] \
- $szDirectory] >= 0} {
- set locatedFile($szDirectory/$szFileName) \
- [split [exec find $szDirectory -name $szFileName \
- -print] "\n"]
- } else {
- return {}
- }
- }
- }
- return $locatedFile($szDirectory/$szFileName)
-}
-
-# appendArguments
-#
-# This procedure will append the string pathed in arguments to every
-# element of fileList
-# return a list with the same number of element in which each
-# element has the arguments appended
-#
-proc appendArguments {fileList arguments} {
- set newList {}
- debug {======= appendArguments $fileList $arguments} 3
- debug { length argument list: >[llength $arguments]<} 4
- if {[string length $arguments] > 0} {
- foreach file $fileList {
- regexp {([^[=]+)([[][^]]*[]])?(.*)} $file dummy szT szID szA
- debug {dummy: >$dummy<} 4
- debug {szT : >$szT<} 4
- if {[string length $szID] > 0} {
- #regexp {[[]([^]]+)[]]} $szID dummy szID
- }
- debug {szID : >$szID<} 4
- if {[string length $szA] > 0} {
- regexp {=(.*)} $szA dummy szA
- }
- debug {szA : >$szA<} 4
- #set lFile [split $file "="]
- if {[string length $szA] > 0} {
- set szSep " "
- } else {
- set szSep "="
- }
- lappend newList ${file}${szSep}$arguments
- }
- return $newList
- }
- return $fileList
-}
-
-# appendTestCaseID
-#
-# This procedure will append the string pathed in arguments to every
-# element of fileList
-# return a list with the same number of element in which each
-# element has the arguments appended
-#
-proc appendTestCaseID {fileList {szTestCaseID ""}} {
- set newList {}
- debug {======= appendTestCaseID $fileList >$szTestCaseID<} 3
- set bMultiFiles [expr [llength $fileList] > 1]
- set i 1
- foreach file $fileList {
- regexp {([^[=]+)([[][^]]*[]])?(.*)} $file dummy szT szID szA
- debug {dummy: >$dummy<} 4
- debug {szT : >$szT<} 4
- if {[string length $szID] > 0} {
- regexp {[[]([^]]+)[]]} $szID dummy szID
- }
- debug {szID : >$szID<} 4
- if {[string length $szA] > 0} {
- #regexp {=(.*)} $szA dummy szA
- }
- debug {szA : >$szA<} 4
- if {[string length $szID] > 0} {
- set szID [string trim "${szID}${szTestCaseID}"]
- } else {
- set szID ${szTestCaseID}
- }
- if {[llength [split $szID "="]] > 1} {
- set szSep " "
- } else {
- set szSep "="
- }
- if {[string length $szID] == 0} {
- lappend newList "${szT}$szA"
- continue
- }
- if {$bMultiFiles} {
- set szI [format "${szSep}seqNr=%03d" $i]
- } else {
- set szI ""
- }
- lappend newList "${szT}\[${szID}${szI}\]$szA"
- incr i
- }
- return $newList
-}
-
-# processArgs
-#
-# This procedure expect all optional arguments to be name=value pairs
-# It will set all variable named to the value given within
-# the procedure body
-# It will return an empty list or a list of all remaining not name=value
-# pair in the argument list
-#
-proc processArgs {args} {
- debug {======= processArgs $args} 3
-
- set llArgs $args
- set args {}
-
- # set default errorCode=NONE
- uplevel set errorCode NONE
- # now process all name=value pair arguments
- ####### There may be a better way to do this see pre 8.0 code
- foreach lArgs $llArgs {
- foreach arg $lArgs {
- set NVP [split $arg "="]
- if {[llength $NVP] > 1} {
- debug {uplevel set [lindex $NVP 0] \
- [list [join [lrange $NVP 1 end] "="]]} 3
- uplevel set [lindex $NVP 0] \
- [list [join [lrange $NVP 1 end] "="]]
- } else {
- lappend args $arg
- }
- }
- }
- debug { processArgs returns: $args} 3
- return $args
-}
-
-# processInternalArgs
-#
-# This procedure expect all optional arguments to be {name value} pairs
-# It will set all variable named to the value given within
-# the procedure body
-# It will return an empty list or a list of all remaining not name=value
-# pair in the argument list
-#
-proc processInternalArgs {lArgs} {
- debug {======= processInternalArgs $lArgs} 3
- set arglist {}
-
- # set default errorCode=NONE
- uplevel set errorCode NONE
- # now process all {name value} pair arguments
- foreach arg $lArgs {
- if {[llength $arg] == 2} {
- debug {uplevel set [lindex $arg 0] \
- [list [join [lrange $arg 1 end] "="]]} 3
- uplevel set [lindex $arg 0] \
- [list [join [lrange $arg 1 end] "="]]
- } else {
- lappend arglist $arg
- }
- }
- debug {processInternalArgs returns: $arglist} 3
- return $arglist
-}
-
-# processTestScriptArgs
-#
-# This procedure expect all optional arguments to be {name value} pairs
-# It will set all variable named to the value given within
-# the procedure body
-# It will return an empty list or a list of all remaining not name=value
-# pair in the argument list
-#
-# This is a copy of the procedure "processInternalArgs" without an argument
-# however this procedure may become different
-#
-#
-proc processTestScriptArgs {} {
- upvar lArgs lArgs
- set arglist {}
-
- # set default errorCode=NONE
- uplevel set errorCode NONE
- debug {======= processTestScriptArgs $lArgs} 3
- # now process all {name value} pair arguments
- foreach arg $lArgs {
- if {[llength $arg] == 2} {
- debug {uplevel set [lindex $arg 0] \
- [list [join [lrange $arg 1 end] "="]]} 4
- uplevel set [lindex $arg 0] \
- [list [join [lrange $arg 1 end] "="]]
- } else {
- lappend arglist $arg
- }
- }
- debug { processInternalArgs returns: $arglist} 4
- return $arglist
-}
-
-# Command execution command
-# This command is like the catch command, however it can do some additional
-# testing and in case of an error it will return a error class.
-#
-proc doCmd {szCmd args} {
- global errorInfo errorCode
- if {! [info exists errorInfo]} {
- set errorInfo "<errorInfo has not been defined>"
- }
-
- debug {======= doCmd >$szCmd< >$args<} 3
- foreach arg $args {
- set vv [split $arg "="]
- if {[llength $vv] == 2} {
- debug { ==>> Expected value: [lindex $vv 0]=[eval list \
- [lindex $vv 1]]} 5
- set [lindex $vv 0] [eval list [lindex $vv 1]]
- } elseif {[llength $vv] == 1} {
- if {! [info exists errorObj]} {
- debug { ==>> upvar $vv errorObj} 5
- if "! [uplevel info exists $vv]" {
- debug { ==>> creating: $vv (uplevel)} 5
- uplevel [list set $vv {}]
- }
- upvar $vv errorObj
- }
- }
- }
- if {[catch {uplevel 1 $szCmd} szErrMsg]} {
- debug {======= ErrMsg : \n$szErrMsg\n======= from:\n$szCmd} 5
- set errorObj ""
- if {[string compare $errorCode NONE] == 0} {
- set errorCode UNDEFINED
- }
- set errorInfoSave $errorInfo
- set errorCodeSave $errorCode
- catch {set errorObj [uplevel infoWhich \{$szErrMsg\}]}
- set errorInfo $errorInfoSave
- set errorCode $errorCodeSave
- debug { ==>> errorObj: >$errorObj<} 5
- if {[string compare $errorObj ""] == 0} {
- set errorObj [uplevel \
- ::BlueGnu::Error #auto \{$errorCode\} \
- \{$szErrMsg\} \{$errorInfo\}]
- debug {errorObj: >$errorObj<} 5
- set errorObj [uplevel infoWhich \{$errorObj\}]
- debug {errorObj: >$errorObj<} 5
- debug {Command: [string trim $szCmd]} 5
- debug {ErrMsg : \n$szErrMsg} 5
- debug {====================} 5
- global errorInfo
- debug {ErrInfo: $errorInfo\n====================} 5
- }
- set bReturn 1
- if {[info exists errorCode]} {
- debug { errorCode= $errorCode} 5
- debug { Class= [$errorObj info class]} 5
- catch {debug { isa BC_RTN= [$errorObj isa BC_RTN]} 5}
- catch {debug { isa ERROR= [$errorObj isa Error]} 5}
- catch {
- if [$errorObj isa BC_RTN] {
- if {[set i \
- [lsearch -exact $errorCode \
- [list [$errorObj SEVERITY] \
- [$errorObj FACILITY] [$errorObj CODE]]]] >= 0} {
- setup_xfail
- set bReturn 0
- }
- fail "Expected errorCode=$errorCode, got:\
- [$errorObj getShortMsg]\
- \{[$errorObj SEVERITY] [$errorObj FACILITY]\
- [$errorObj CODE]\} for >$szCmd<"
- #verbose { errorCode: [$errorObj errorCode]}
- #verbose { why: [$errorObj why]}
- #verbose {verboseWhy: [$errorObj verboseWhy]} 2
- }
- }
- catch {
- if [$errorObj isa Error] {
- debug { Error= [$errorObj errorCode]} 5
- if {[set i \
- [lsearch -exact $errorCode \
- [$errorObj errorCode]]] >= 0} {
- setup_xfail
- set bReturn 0
- }
- fail "Expected errorCode=$errorCode, got:\
- [$errorObj errorCode] for >$szCmd<"
- verbose { errorCode: [$errorObj errorCode]}
- verbose { why: [$errorObj why]}
- verbose {verboseWhy: [$errorObj verboseWhy]} 2
- }
- }
- }
- return $bReturn
- } else {
- set bReturn 0
- set NOT ""
- if {[info exists errorCode]} {
- if {[lsearch -exact $errorCode "NONE"] < 0} {
- setup_xfail
- set NOT "not "
- set bReturn 1
- }
- pass "errorCode=NONE ${NOT}found in expected set\
- of errorCodes=\{$errorCode\} for >$szCmd<"
- }
- if {[info exists return]} {
- debug {Return: >$return<} 3
- set bResult 0
- set iFalse 0
- set iFalseFound 0
- set iTrue 0
- set iTrueFound 0
- foreach lResult $return {
- if {[llength $lResult] == 2} {
- set bFlag [string toupper [lindex $lResult 0]]
- set szResult [lindex $lResult 1]
- } else {
- set bFlag ""
- set szResult [lindex $lResult 0]
- }
- debug {Checking >$szErrMsg< against $bFlag >$szResult<} 3
- switch $bFlag {
- 0 - NOT - NO - FALSE {
- # no matches allowed
- incr iFalse
- debug {Should not match >$szErrMsg< != >$szResult<} 4
- if {[string compare $szErrMsg $szResult] != 0} {
- pass "The NOT Expected Result >$szResult<\
- was not found for >$szCmd<"
- incr iFalseFound
- } else {
- fail "The NOT Expected Result >$szResult<\
- was found for >$szCmd<"
- }
- }
- 1 - {} - YES - TRUE {
- # only one match allowed
- incr iTrue
- debug {Should match >$szErrMsg< == >$szResult<} 4
- if {[string compare $szErrMsg $szResult] == 0} {
- pass "Expected Result >$szResult<\
- found for >$szCmd<"
- incr iTrueFound
- }
- }
- default {
- perror "doCmd result flag: 1, 0, <empty>,\
- NOT, YES, NO, TRUE, FALSE"
- }
- }
- }
- set bResult [expr $iFalse == $iFalseFound]
- if {$iTrue > 0} {
- set bResult [expr $bResult && ($iTrueFound == 1)]
- }
- if {! $bResult} {
- fail "Expected Result(s) >$return<\n \
- did not match with: >$szErrMsg< for >$szCmd<"
- set bReturn 1
- }
- }
- if {[info exists errorObj]} {
- set errorObj $szErrMsg
- }
- }
- return $bReturn
-}
-
-
-# deleteObjects
-#
-# This procedure takes multiple arguments each can be a single object
-# or a list of objects
-# it will delete all these object
-# No return value
-#
-proc deleteObjects {args} {
- debug {======= deleteObjects $args} 3
- foreach arg $args {
- foreach object $arg {
- debug " delete object >$object<" 4
- delete object $object
- }
- }
- return {}
-}
-
-# isObject
-# This procedure accepts a fully qualified object name as argument
-# and checks if that object exists
-proc isObject {object} {
- debug {======= isObject $object} 3
- set tmp [namespace tail $object]
- return [expr [lsearch [namespace eval [namespace qualifier $object] {
- ::itcl::find objects
- }
- ] $tmp] >= 0]
-}
-
-# checkObject
-# This procedure takes an object and a class name is argument
-# It checks if the object exists, has a counter part in C++ and
-# is of the correct class
-#
-proc checkObject {object szClassName} {
- debug {======= checkObject $object $szClassName} 3
- if {! [catch {
- set class [uplevel "$object info class"]
- if {[catch {[findObject $object] isa $szClassName} bCl]} {
- if {[string compare [namespace tail $class] \
- [namespace tail $szClassName]] == 0} {
- debug {Class [namespace tail $szClassName]\
- match class of object} 4
- } else {
- error "Miss match"
- }
- } elseif {! $bCl} {
- error 1
- }
- } iRet]} {
- return 1
- }
-
- set obj [findObject $object]
- set class [findClass $szClassName]
- if {[string length $obj] > 0 && [string length $class] > 0} {
- debug { ==>> object and class passed do exists} 4
- if {[catch {set bISA [$obj isa $class]}]} {
- debug {Class $szClassName is not inscope to match $object} 4
- return 0
- }
- if {! $bISA} {
- debug {$object is not of Class $szClassName} 4
- return 0
- }
- } else {
- debug {$object and/or $szClassName have not been found!} 4
- return 0
- }
- return 1
-}
-
-# findObject
-# This procedure take the name of an object, possibly without any qualifier
-# and search all namespaces to find the object.
-# When a qualifier is specified, it will check if it is complete
-# The procedure return the fully qualified name of the object if it exists or
-# an empty string otherwise.
-#
-proc findObject {object {namespace ::}} {
- debug {======= findObject $object $namespace} 3
- set ns [namespace qualifier $object]
- set obj [namespace tail $object]
- set objs [namespace eval $namespace {::itcl::find objects}]
- if {[lsearch $objs $obj] >= 0} {
- regsub "::$" $namespace "" namespace
- return ${namespace}::$obj
- } else {
- set result ""
- foreach cns [namespace children $namespace] {
- set result [findObject $obj $cns]
- if {[string length $result] > 0} break
- }
- }
- return $result
-}
-
-# findClass
-# This procedure take the name of an class, possibly without any qualifier
-# and search all namespaces to find the class.
-# When a qualifier is specified, it will check if it is complete
-# The procedure return the fully qualified name of the Class if it exists or
-# an empty string otherwise.
-#
-proc findClass {class {namespace ::}} {
- debug {======= findClass $class $namespace} 3
- set ns [namespace qualifier $class]
- set obj [namespace tail $class]
- set objs [namespace eval $namespace {::itcl::find classes}]
- if {[lsearch $objs $obj] >= 0} {
- regsub "::$" $namespace "" namespace
- return ${namespace}::$obj
- } else {
- set result ""
- foreach cns [namespace children $namespace] {
- set result [findClass $obj $cns]
- if {[string length $result] > 0} break
- }
- }
- return $result
-}
-
-# The parseTest command will validate the argument as an existing
-# test including testCaseID and arguments.
-# It will return a list of all acceptable test script
-#
-proc parseTest {args} {
- global szCurrentTestDirectory
- debug {======= parseTest $args} 3
-
- foreach arg $args {
- foreach szTest $arg {
- regexp {([^[=]+)([[][^]]*[]])?(.*)} $szTest dummy szT szID szA
- debug {dummy: >$dummy<} 4
- debug {szT : >$szT<} 4
- if {[string length $szID] > 0} {
- #regexp {[[]([^]]+)[]]} $szID dummy szID
- }
- debug {szID : >$szID<} 4
- if {[string length $szA] > 0} {
- #regexp {=(.*)} $szA dummy szA
- }
- debug {szA : >$szA<} 4
- set szFileName $szT
- set szDname [file dirname $szFileName]
- set szFname [file tail $szFileName]
-
- if {[file exist [set test [file join \
- $szCurrentTestDirectory \
- $szFileName]]]} {
- # file should be a test
- debug { is a test: >$test<!} 3
- lappend testList [file join $szCurrentTestDirectory $szTest]
- } elseif {[llength [set tests \
- [locateFile $szFname $szDname]]] > 0} {
- foreach test $tests {
- if {[file exists $test]} {
- # file should be a test
- debug { is a test: >$test<!!} 3
- lappend testList ${test}${szID}${szA}
- } else {
- warning "Test >$test< can't be found"
- }
- }
- } else {
- perror "$szFileName is not a test!\
- Does not exists!"
- }
- }
- }
- if [info exists testList] {
- if [llength $testList] {
- return $testList
- }
- }
- return [list]
-}
-
-# The global available runtest procedure
-# this procedure will find the current environment
-# and execute the runTest procedure in that environment
-
-proc runtest {args} {
- global objCurrentEnvironment szCurrentTestDirectory
- debug {======= runtest $args} 3
- set elResult [list]
-
- if {[llength $args] > 0} {
- set Env [lindex $args 0]
- debug { Checking for environment: >$Env<} 3
- debug { >[infoWhich $Env]<} 5
- debug { Current Test Directory: >$szCurrentTestDirectory<} 5
- if {[string compare [infoWhich $Env] ""] == 0} {
- debug { not an environment} 4
- if {[info exist objCurrentEnvironment] && \
- [string compare \
- [infoWhich $objCurrentEnvironment] ""] != 0} {
- debug { Found Current Environment\
- >$objCurrentEnvironment<} 5
- set Env $objCurrentEnvironment
- } else {
- error "NO default environent"
- }
- } else {
- debug { is an environment} 3
- set args [lrange $args 1 end]
- }
- set T [lindex $args 0]
- set A [lindex $args 1]
- set I [lindex $args 2]
- foreach t [appendTestCaseID [appendArguments [parseTest $T] $A] $I] {
- debug { ==>> $objCurrentEnvironment\
- runTest $t} 3
- lappend elResult \
- [$Env runTest $t]
- }
- } else {
- warning "No tests have been passed to runtest procedure!"
- }
- return $elResult
-}
-
-proc appendQueue {args} {
- global objCurrentQueue szCurrentTestDirectory
- debug {======= appendQueue $args} 3
-
- set iRun 0
- set Queue [lindex $args 0]
- if {[string compare [infoWhich $Queue] ""] == 0} {
- if {[info exist objCurrentQueue]} {
- set Queue $objCurrentQueue
- } else {
- error "NO default queue"
- }
- } else {
- set args [lrange $args 1 end]
- }
- set T [lindex $args 0]
- set A [lindex $args 1]
- set I [lindex $args 2]
- foreach t [appendTestCaseID [appendArguments [parseTest $T] $A] $I] {
- debug { ==>> $Queue append $t} 3
- incr iRun
- $Queue append $t
- }
- if {$iRun == 0} {
- warning "NO argument to appendQueue have been processed"
- }
-}
-
-proc prependQueue {args} {
- global objCurrentQueue szCurrentTestDirectory
- debug {======= prependQueue $args} 3
-
- set iRun 0
- set Queue [lindex $args 0]
- if {[string compare [infoWhich [lindex $args 0]] ""] == 0} {
- if {[info exist objCurrentQueue]} {
- set Queue $objCurrentQueue
- } else {
- error "NO default queue"
- }
- } else {
- set args [lrange $args 1 end]
- }
- set T [lindex $args 0]
- set A [lindex $args 1]
- set I [lindex $args 2]
- foreach t [appendTestCaseID [appendArguments [parseTest $T] $A] $I] {
- incr iRun
- lappend comList $t
- }
- debug { ==>> $Queue prepend $comList} 3
- eval $Queue prepend $comList
-
- if {$iRun == 0} {
- warning "NO argument to appendQueu have been processed"
- }
-}
-
-proc perror {args} {
- global errorInfo
- global objCurrentTest
- global objCurrentEnvironment
-
- # save errorInfo
- set errorInfoSave $errorInfo
-
- if { [llength $args] > 1 } {
- set $::BlueGnu::errcnt [lindex [uplevel set args] 1]
- } else {
- incr ::BlueGnu::errcnt
- }
-
- while 1 {
- set szMsg [lindex $args 0]
-
- if {[catch {$objCurrentTest perror $szMsg} \
- szErrMsg]} {
- if {[info exists objCurrentTest]} {
- debug {No current test: >$szErrMsg<:\
- current test >$objCurrentTest< message:\n \
- $szMsg} 3
- } else {
- debug {PERROR: No current test: >$szErrMsg<:\
- current test >DOES NOT EXIST< message:\n \
- $szMsg} 3
- debug { info: >>>$errorInfo<<<} 4
- }
- } else {
- break
- }
- catch {
- set szCmd [concat \"$objCurrentEnvironment\" record_test \
- ERROR \$szMsg]
- }
- if {[catch {eval $szCmd} szErrMsg]} {
- verbose {No current environment (ERROR): >$szErrMsg<} 3
- } else {
- break
- }
-
- ::BlueGnu::clone_output "ERROR: $szMsg"
- namespace eval ::BlueGnu {
- set errno "ERROR: [uplevel set szMsg]"
- }
- break
- }
-
- # restore errorInfo
- set errorInfo $errorInfoSave
-}
-
-proc warning {args} {
- global errorInfo
- global objCurrentTest
- global objCurrentEnvironment
-
- # save errorInfo
- set errorInfoSave $errorInfo
-
- if { [llength $args] > 1 } {
- namespace eval ::BlueGnu {
- set warncnt [lindex [uplevel set args] 1]
- }
- } else {
- namespace eval ::BlueGnu {
- incr warncnt
- }
- }
-
- while 1 {
- set szMsg [lindex $args 0]
-
- if {[catch {$objCurrentTest warning $szMsg} \
- szErrMsg]} {
- if {[info exists objCurrentTest]} {
- verbose {No current test: >$szErrMsg<:\
- current test >$objCurrentTest< message:\n \
- $szMsg} 3
- } else {
- verbose {WARNING: No current test: >$szErrMsg<:\
- current test >DOES NOT EXIST< message:\n \
- $szMsg} 3
- }
- } else {
- break
- }
- catch {
- set szCmd [concat \"$objCurrentEnvironment\" record_test \
- WARNING \$szMsg]
- }
- if {[catch {eval $szCmd} szErrMsg]} {
- verbose {No current environment (WARNING): >$szErrMsg<} 3
- } else {
- break
- }
-
- set szMsg [lindex $args 0]
- ::BlueGnu::clone_output "WARNING: $szMsg"
- namespace eval ::BlueGnu {
- set errno "WARNING: [uplevel set szMsg]"
- }
- break
- }
- if 0 {
- uplevel #0 {
- verbose {uplevel #0 to remove errorInfo}
- if [info exists errorInfo] {
- unset errorInfo
- }
- }
- }
- # restore errorInfo
- set errorInfo $errorInfoSave
-}
-
-proc note {szMsg} {
- global objCurrentTest
-
- $objCurrentTest note $szMsg
-}
-
-proc pass {szMsg} {
- global objCurrentTest
-
- $objCurrentTest pass $szMsg
-}
-
-proc fail {szMsg} {
- global objCurrentTest
-
- $objCurrentTest fail $szMsg
-}
-
-proc unresolved {szMsg} {
- global objCurrentTest
-
- $objCurrentTest unresolved $szMsg
-}
-
-proc untested {szMsg} {
- global objCurrentTest
-
- $objCurrentTest untested $szMsg
-}
-
-proc unsupported {szMsg} {
- global objCurrentTest
-
- $objCurrentTest unsupported $szMsg
-}
-
-proc get_warning_threshold {} {
- return [namespace eval ::BlueGnu {set warning_threshold}]
-}
-
-proc set_warning_threshold {threshold} {
- namespace eval ::BlueGnu {
- set warning_threshold [uplevel set threshold]
- }
-}
-
-proc setup_xfail {args} {
- namespace eval ::BlueGnu {set xfail_flag 1}
-}
-
-proc clear_xfail {args} {
- namespace eval ::BlueGnu {set xfail_flag 0}
-}
-
-proc benchmark {benchmarkFunction args} {
- debug {======= benchmark $benchmarkFunction $args}
- global objCurrentTest
- global errorInfo
-
- if 0 {
- debug {[foreach var [info vars] {
- verbose {local var: >$var<}}]
- }
- uplevel {
- debug {[foreach var [info vars] {
- verbose {uplevel local var: >$var<}}]
- }
- }
- debug {[foreach var [info globals] {
- verbose {global var: >$var<}}]
- }
- }
-
- set errorInfo ""
- set szID [$objCurrentTest ID]
- set szTestCaseID [$objCurrentTest testCaseID]
- set benchmarkObject [$objCurrentTest benchmarkObject]
- set benchmarkClassName [$objCurrentTest benchmarkClassName]
- debug { ==>> test ID: >$szID<} 3
- debug { test case ID: >$szTestCaseID<} 3
- debug { check test object: >$benchmarkObject<} 3
- if {$benchmarkObject == ""} {
- warning "NO Benchmark Class defines for >$benchmarkClassName<"
- set bResult 0
- } else {
- if [catch {
- set bResult [eval $benchmarkObject benchmark \
- $benchmarkFunction $args]
- } errMsg] {
- warning "NO checking has been done for\
- ${benchmarkClassName}::benchmark $benchmarkFunction $args"
- debug {[perror "BenchmarkFunction: >$benchmarkFunction<\
- has not been defined\
- in class $benchmarkClassName\n### Error Msg: $errMsg"]} 0
- debug {### Error Info: $errorInfo} 0
- set bResult 0
- }
- }
- return $bResult
-}
-
-proc envPATH {szAction szDir} {
- debug {======= envPATH $szAction $szDir} 3
-
- global env
- if [file isdirectory $szDir] {
- # remove directory from Path if it exists
- set envPATH $env(PATH)
- while {[regsub :?$szDir:? $envPATH {:} envPATH]} {
- }
- regsub {^:} $envPATH {} envPATH
- regsub {:$} $envPATH {} envPATH
- set env(PATH) $envPATH
- switch $szAction {
- prefix -
- prepend {
- set env(PATH) "$szDir:$env(PATH)"
- }
- append {
- append env(PATH) ":$szDir"
- }
- default {
- }
- }
- }
-}
-
-# replacement for info which commaond
-#
-proc infoWhich {name {namespace ::}} {
- debug {======= infoWhich $name $namespace} 3
- if [catch {uplevel set infoWhich__name $name} szErrMsg] {
- debug { error: $szErrMsg}
- return ""
- }
- uplevel {
- debug { objects: >[::itcl::find objects]<} 4
- debug { namespace: >[namespace current]<} 4
- infoWhichYYY
- }
- set name [uplevel set infoWhich__name]
- uplevel unset infoWhich__name
- debug {infoWhich return: >$name<} 4
- return $name
-}
-proc infoWhichXXX {} {
- uplevel {
- set i [lsearch -regexp [::itcl::find objects] "[namespace tail \
- $infoWhich__name]"]
- if {$i < 0} {
- set infoWhich__name ""
- } else {
- set infoWhich__name [lindex [::itcl::find objects] $i]
- if {! [string match ::* $infoWhich__name]} {
- set infoWhich__name [namespace current]::$infoWhich__name
- }
- regsub "^::::" $infoWhich__name "::" infoWhich__name
- }
- }
-}
-proc infoWhichYYY {} {
- uplevel {
- if [catch {infoWhichXXX} szErrMsg] {
- verbose "infoWhichYYY error Msg: $szErrMsg"
- set infoWhich__name ""
- }
- }
-}
-
-namespace eval ::BlueGnu {
- variable warning_threshold 0
-
- variable sum_file stdout
- variable all_flag 0
-
- variable xfail_flag 0
- variable xfail_prms {}
- #
- # Print output to stdout (or stderr) and to log file
- #
- # If the --all flag (-a) option was used then all messages
- # go the the screen.
- # Without this, all messages that start with a keyword are
- # written only to the
- # detail log file. All messages that go to the screen will
- # also appear in the
- # detail log. This should only be used by the framework itself using pass,
- # fail, xpass, xfail, warning, perror, note, untested, unresolved, or
- # unsupported procedures.
- #
- proc clone_output {message} {
- variable sum_file
- variable all_flag
-
- #everything goes in the summary file
- #
- puts $sum_file "$message"
-
- # Depending on the type of message, the message is send
- # to other resources
- #
- case [lindex [split $message] 0] in {
- {"FAIL:" "XPASS:" "UNRESOLVED:" "UNSUPPORTED:" "UNTESTED:"} {
- send_user "$message\n"
- send_log "$message\n"
- }
- {"PASS:" "XFAIL:"} {
- if $all_flag {
- send_user "$message\n"
- }
- send_log "$message\n"
- }
- "ERROR:" {
- #send_user "$message\n"
- send_error "$message\n"
- send_log "$message\n"
- }
- {"WARNING:" "NOTE:"} {
- if $all_flag {
- send_error "$message\n"
- }
- send_log "$message\n"
- }
- "*******" {
- send_user "$message\n"
- #send_log "$message\n"
- #send_error "$message\n"
- }
- default {
- send_user "$message\n"
- }
- }
-
- # we always return turn the message unchanged
- #
- return "$message"
- }
-}
-
-proc createTarget {args} {
- verbose {In: createTarget >$args<} 3
- set szCmd "::BlueGnu::Target #auto "
- set bID 0
- set bEnv 0
- set bQueue 0
- foreach item $args {
- if {[string compare \
- [lindex [split $item "="] 0] szID] == 0} {
- set bID 1
- }
- if {[string compare \
- [lindex [split $item "="] 0] objEnvironment] == 0} {
- set bEnv 1
- }
- if {[string compare \
- [lindex [split $item "="] 0] objQueue] == 0} {
- set bQueue 1
- }
- append szCmd "\{$item\} "
- }
- if {! $bID} {
- append szCmd "szID=Default "
- }
- if {! $bEnv} {
- append szCmd "objEnvironment=[infoWhich \
- [::BlueGnu::Environment #auto]] "
- }
- if {! $bQueue} {
- append szCmd "objQueue=[infoWhich [::BlueGnu::Queue #auto]] "
- }
- verbose {Command: >$szCmd<} 3
- set target [uplevel #0 "eval $szCmd"]
- verbose {Created target: >$target<} 3
- verbose { >>>[$target <<]<<<} 4
- verbose { >>>[[infoWhich $target] <<]<<<} 4
- verbose { == [join [$target <<] "\n == "]} 3
- return [infoWhich $target]
-}
-
-# Initialize all global variables not yet initialized
-#
-set szCurrentTestDirectory $env(TESTSUITEROOT)
-
-# Remove all temporary variables from the global space
-catch {eval unset [info globals __*]}
-debug {Global variables available:\
- \n [join [lsort [info globals]] "\n "]} 9
-debug {Global procedures available:\
- \n [join [lsort [info procs]] "\n "]} 9
-
-foreach dir [split $env(TESTSETS) ":"] {
- if {[string compare $dir $PWD] == 0} {
- foreach indexFile [locateFile tclIndex] {
- set indexDir [file dirname $indexFile]
- if {[lsearch -exact [split $auto_path] $indexDir] < 0} {
- set auto_path "$indexDir $auto_path"
- }
- }
- foreach indexFile [locateFile tclIndex lib] {
- set indexDir [file dirname $indexFile]
- if {[lsearch -exact [split $auto_path] $indexDir] < 0} {
- set auto_path "$indexDir $auto_path"
- }
- }
- } else {
- if {[file exists $dir/tclIndex]} {
- set auto_path "$dir $auto_path"
- }
- }
-}
-debug {auto_path has been intialize to:\n [join $auto_path "\n "]} 3
-verbose {TESTSETS: >$env(TESTSETS)<} 3
generated by cgit v1.1 at 2024-07-17 00:07:09 +0000