diff options
Diffstat (limited to 'contrib/bluegnu2.0.3/lib/testSessionFramework.itcl')
-rw-r--r-- | contrib/bluegnu2.0.3/lib/testSessionFramework.itcl | 1386 |
1 files changed, 1386 insertions, 0 deletions
diff --git a/contrib/bluegnu2.0.3/lib/testSessionFramework.itcl b/contrib/bluegnu2.0.3/lib/testSessionFramework.itcl new file mode 100644 index 0000000..7f96880 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/testSessionFramework.itcl @@ -0,0 +1,1386 @@ +# +# +# +# +# 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 |