aboutsummaryrefslogtreecommitdiff
path: root/contrib/bluegnu2.0.3/lib/testSessionClasses.itcl
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/bluegnu2.0.3/lib/testSessionClasses.itcl')
-rw-r--r--contrib/bluegnu2.0.3/lib/testSessionClasses.itcl1341
1 files changed, 0 insertions, 1341 deletions
diff --git a/contrib/bluegnu2.0.3/lib/testSessionClasses.itcl b/contrib/bluegnu2.0.3/lib/testSessionClasses.itcl
deleted file mode 100644
index a9428af..0000000
--- a/contrib/bluegnu2.0.3/lib/testSessionClasses.itcl
+++ /dev/null
@@ -1,1341 +0,0 @@
-#
-# This [incr Tcl] source file contains the class specifications
-# for the testSession of BlueGnu
-#
-namespace eval ::BlueGnu {
- variable lArgs {}
-
- variable errcnt 0
- variable errno "NONE"
- variable warncnt 0
- variable xfail_flag 0
-
- class Common {
- # arguments passed to the constructor are always in the form:
- # <variable>=<value>
- #
- constructor {args} {
- debug {Constructor for >$this< [info level] [info class]} 9
- foreach varval $args {
- set varval [split $varval "="]
- if {[llength $varval] != 2} {
- error "Missing <variable>=<value> pair"
- }
- set var [lindex $varval 0]
- set val [lindex $varval 1]
- set variables {}
- foreach v [lsort [info variable]] {
- regexp {[^:]+$} $v v
- lappend variables $v
- }
- if {[lsearch -exact $variables $var] >= 0} {
- set $var $val
- } else {
- perror "variable >$var< does not exists in Class\
- [info class]\n \
- (was passed as argument and is ignored!)"
- }
- }
- }
-
- public method << {} {
- set lResult {}
- foreach var [lsort [info variable]] {
- regexp {[^:]+$} $var v
- debug {Found variable: >$v<} 9
- if [array exists $v] {
- debug { is an array} 9
- foreach index [lsort [array names $v]] {
- lappend lResult "${v}($index)=[set ${v}($index)]"
- }
- } else {
- debug { is simple variable} 9
- if {[string compare [set value [info variable $var -value]] \
- "<undefined>"] != 0} {
- switch $v {
- this -
- text {}
- default {
- lappend lResult [list $v $value]
- }
- }
- }
- }
- }
- set lResult
- }
- }
-
- class Test {
- inherit Common
-
- protected variable szID
- protected variable bTestCase
- protected variable szTestCase
- protected variable szTestCaseID
- protected variable szTestCaseArgs
- protected variable szName
- protected variable szTool
- protected variable eType
- protected variable eResult
- protected variable szScriptName
- protected variable lArguments
- protected variable szHostName
- protected variable iPassed
- protected variable iFailed
- protected variable iXPassed
- protected variable iXFailed
- protected variable iCrashed
- protected variable iError
- protected variable iWarning
- protected variable iUnresolved
- protected variable iUntested
- protected variable iUnsupported
- protected variable i
- protected variable benchmarkObject
- protected variable benchmarkClassName
-
- constructor testScript {
- set szTool [uplevel #0 set szCurrentTestDirectory]
- debug {======= Global Default Test Directory is\
- >$szTool<} 5
-
- set lArguments {}
- # remove all multiple spaces/tabs into one space
- # and parse the argument list
- # <testScript> ::= <szScriptName>?[test case ID]?=<argument list>
- # <argument list> ::= <argument> <argument list>
- # <argument> ::= <variable name> | <variable name>=<value>
- debug { testScript(1) is >$testScript<} 5
- regsub -all "(\[ \t\]+)" [string trim $testScript] " " testScript
- debug { testScript(2) is >$testScript<} 5
- #
- # Split testScript into script, test case ID, and arguments
- regexp {^([^[=]+)([[]([^]]+)[]])?(=(.*))?$} $testScript dummy \
- script tc tcID argT argL
- debug { script: >$script<} 5
- debug { tc: >$tc<} 5
- debug { tcID: >$tcID<} 5
- debug { argT: >$argT<} 5
- debug { argL: >$argL<} 5
- if {[set i [string first {=} $testScript]] >= 0} {
- set testScriptArgs [string range $testScript \
- [expr $i + 1] end]
- set testScript [string range $testScript 0 [expr $i - 1]]
- } else {
- set testScriptArgs {}
- }
- set testScript $script
- set szTestCase $tcID
- if {[string length $szTestCase] > 0} {
- set bTestCase 1
- } else {
- set bTestCase 0
- }
- set szTestCaseID [lindex [split $szTestCase "="] 0]
- set szTestCaseArgs [join [lrange [split $szTestCase "="] 1 end] \
- "="]
- debug {szTestCase == >$szTestCase<} 5
- debug {szTestCaseID == >$szTestCaseID<} 5
- debug {szTestCaseArgs == >$szTestCaseArgs<} 5
- set testScriptArgs $argL
- debug {testScript(3) is >$testScript<} 5
- debug {testScriptArgs(1) is >$testScriptArgs<} 5
- set lArguments [eval list $testScriptArgs]
- set i 0
- foreach arg $lArguments {
- debug {arg($i) is >$arg<} 5
- set lArguments [lreplace $lArguments $i $i [split $arg "="]]
- incr i
- }
- debug {Test script >$testScript<, test case >$szTestCase<} 3
- debug { pathtype is [file pathtype $testScript]} 3
- switch [file pathtype $testScript] {
- relative {
- error "Test Script name >$testScript<\
- should not be relative"
- }
- absolute {
- debug {Absolute reference in $this to Test Script\
- >$testScript<} 3
- set szScriptName $testScript
- }
- }
- debug {Default Test Directory is >$szTool<}
- if {[file exists $testScript]} {
- debug {Test script >$testScript< exists!}
- set szName [file tail $testScript]
- set szID [file rootname $szName]
- set szPWD [pwd]
- set szTool [file dirname $testScript]
- cd $szTool
- set szTool [pwd]
- cd $szPWD
- set szScriptName [file join $szTool [file tail $testScript]]
- regsub {.} [string toupper [file extension $szName]] {} eType
- set eResult INITIALIZED
- } else {
- debug {Test script >$testScript< does NOT exists!}
- set szRoot ""
- set szID ""
- set szName ""
- set szTool ""
- uplevel #0 set szCurrentTestDirectory "\"$szTool\""
- set eType "NONE"
- set szScriptName "$testScript"
- set lArguments {}
- set eResult EMPTY
- }
- set szHostName [info host]
- set iPassed 0
- set iFailed 0
- set iXPassed 0
- set iXFailed 0
- set iCrashed 0
- set iError 0
- set iWarning 0
- set iUnresolved 0
- set iUntested 0
- set iUnsupported 0
- debug {Default Test Directory is >$szTool<}
- debug {Global Default Test Directory is\
- >[uplevel #0 set szCurrentTestDirectory]<}
-
- debug {Target: >[[uplevel #0 set objCurrentTarget] <<]<}
-
- while {1} {
- # Create Benchmark Class Object
- #
- # First initialize
- #
- set szTargetID [[uplevel #0 set objCurrentTarget] ID]
- regsub -all {[^a-zA-Z0-9_]} $szTargetID "_" szTargetID
- regsub -all {[^a-zA-Z0-9_]} $szID "_" szTmpID
- regsub -all {[^a-zA-Z0-9_]} $szTestCaseID "_" szTmpTestCaseID
- #
- # First try Benchmark Class in namespace for Target
- # and test case ID if exists otherwise test script ID
- #
- set benchmarkClassName ::$szTargetID
- if {$bTestCase} {
- append benchmarkClassName ::$szTmpTestCaseID
- } else {
- append benchmarkClassName ::$szTmpID
- }
- debug {=== Trying benchmark: $benchmarkClassName} 3
- if [catch {
- set benchmarkObject \
- [eval $benchmarkClassName #auto $szTestCaseArgs]
- if {! [string match ::* $benchmarkObject]} {
- set benchmarkObject \
- [namespace current]::$benchmarkObject
- }
- debug {benchmarkObject: >$benchmarkObject<} 3
- } errMsg] {
- debug {Error Msg: >>>$errMsg<<<} 3
- debug { info: >>>[uplevel #0 set errorInfo]<<<} 4
- } else {
- break
- }
- #
- # Now try Benchmark class for test script name
- # with test case ID or Benchmark
- #
- set benchmarkClassName ::$szTmpID
- if {$bTestCase} {
- append benchmarkClassName ::$szTmpTestCaseID
- } else {
- append benchmarkClassName ::Benchmark
- }
- debug {=== Trying benchmark: $benchmarkClassName} 3
- if [catch {
- set benchmarkObject [infoWhich \
- [eval $benchmarkClassName #auto $szTestCaseArgs]]
- } errMsg] {
- debug {Error Msg: >>>$errMsg<<<} 3
- debug { info: >>>[uplevel #0 set errorInfo]<<<} 4
- } else {
- break
- }
- #
- # Now try target ID and benchmark
- #
- set benchmarkClassName ::${szTargetID}::Benchmark
- debug {=== Trying benchmark: $benchmarkClassName} 3
- debug { namespace: >[namespace current]<} 3
- if [catch {
- set benchmarkObject [infoWhich \
- [eval $benchmarkClassName #auto $szTestCaseArgs] \
- [namespace current]]
- } errMsg] {
- debug {Error Msg: >>>$errMsg<<<} 3
- debug { info: >>>[uplevel #0 set errorInfo]<<<} 4
- } else {
- break
- }
- #
- # Now try the generic BlueGnu benchmark function
- #
- set benchmarkClassName ::BlueGnu::Benchmark
- debug {=== Trying benchmark: $benchmarkClassName} 3
- if [catch {
- set benchmarkObject [infoWhich \
- [eval $benchmarkClassName #auto $szTestCaseArgs]]
- debug {[warning "Default Benchmark Class\
- is being used!"]}
- } errMsg] {
- warning "NO Benchmark Class >$benchmarkClassName<\
- defined"
- debug {[warning "Class: >$benchmarkClassName<\
- has not been defined.\n ### Error Msg:\
- $errMsg"]}
- set benchmarkObject ""
- break
- }
- debug { benchmark: $benchmarkClassName\
- ($benchmarkObject)} 3
- uplevel #0 {
- set errorInfo NONE
- }
- break
- }
- }
-
- destructor {
- setResult
- switch $eResult {
- PASSED {
- printResult
- if {! $bTestCase} {
- ::BlueGnu::clone_output " Statistics :\
- $iPassed (PASS),\
- $iXFailed (XFAIL)"
- }
- }
- FAILED {
- printResult
- if {! $bTestCase} {
- ::BlueGnu::clone_output " Statistics :\
- $iPassed (PASS),\
- $iXFailed (XFAIL)"
- ::BlueGnu::clone_output " :\
- $iFailed (FAIL),\
- $iXPassed (XPASS)"
- }
- }
- UNKNOWN {
- }
- default {
- printResult
- if {! $bTestCase} {
- ::BlueGnu::clone_output " Statistics :\
- $iPassed (PASS),\
- $iXFailed (XFAIL)"
- ::BlueGnu::clone_output " :\
- $iFailed (FAIL),\
- $iXPassed (XPASS)"
- if {$iUntested} {
- ::BlueGnu::clone_output " :\
- $iUntested (UNTESTED)"
- }
- if {$iUnresolved} {
- ::BlueGnu::clone_output " :\
- $iUnresolved (UNRESOLVED)"
- }
- if {$iUnsupported} {
- ::BlueGnu::clone_output " :\
- $iUnsupported (UNSUPPORTED)"
- }
- if {$iCrashed} {
- ::BlueGnu::clone_output " :\
- $iCrashed (CRASHED)"
- }
- if {$iError} {
- ::BlueGnu::clone_output " :\
- $iError (ERROR)"
- }
- if {$iWarning} {
- ::BlueGnu::clone_output " :\
- $iWarning (WARNING)"
- }
- }
- }
- }
- # remove benchmark Class Object
- #
- if {$benchmarkObject != ""} {
- debug {#### Benchmark Object: >$benchmarkObject<\
- ([catch {$benchmarkObject info class}])} 3
- debug {#### Benchmark Class : >$benchmarkClassName<} 3
- catch {delete object $benchmarkObject}
- if {$benchmarkClassName != "::BlueGnu::Benchmark"} {
- catch {delete class $benchmarkClassName}
- }
- }
- ::BlueGnu::clone_output ""
- }
-
- private method printResult {} {
- if {$bTestCase} {
- ::BlueGnu::clone_output "******* Result :\
- [format "%-12s" $eResult] for test case :\
- >$szTestCase<"
- } else {
- ::BlueGnu::clone_output "******* Result :\
- [format "%-12s" $eResult] for test script :\
- >$szID<"
- }
- }
-
- public method ID {} {
- return $szID
- }
-
- public method testCase {} {
- return $szTestCase
- }
-
- public method testCaseID {} {
- return $szTestCaseID
- }
-
- public method testCaseArgs {} {
- return $szTestCaseArgs
- }
-
- public method benchmarkObject {} {
- return $benchmarkObject
- }
-
- public method benchmarkClassName {} {
- return $benchmarkClassName
- }
-
- public method name {args} {
- if {[llength $args] == 1} {
- set szName [lindex $args 0]
- }
- return $szName
- }
-
- public method result {} {
- return $eResult
- }
-
- public method arguments {} {
- return $lArguments
- }
-
- public method pass {szMsg} {
- global objCurrentEnvironment
- if {[namespace eval ::BlueGnu {set xfail_flag}]} {
- incr iXPassed
- $objCurrentEnvironment record_test XPASS $szMsg
- } else {
- incr iPassed
- $objCurrentEnvironment record_test PASS $szMsg
- }
- setResult
- }
- public method fail {szMsg} {
- global objCurrentEnvironment
- if {[namespace eval ::BlueGnu {set xfail_flag}]} {
- incr iXFailed
- $objCurrentEnvironment record_test XFAIL $szMsg
- } else {
- incr iFailed
- $objCurrentEnvironment record_test FAIL $szMsg
- }
- setResult
- }
-
- public method perror {szMsg} {
- global objCurrentEnvironment
- incr iError
- $objCurrentEnvironment record_test ERROR $szMsg
- setResult
- }
-
- public method crashed {szMsg} {
- global objCurrentEnvironment
- incr iCrashed
- $objCurrentEnvironment record_test CRASHED $szMsg
- setResult
- }
-
- public method warning {szMsg} {
- global objCurrentEnvironment
- incr iWarning
- $objCurrentEnvironment record_test WARNING $szMsg
- setResult
- }
-
- public method note {szMsg} {
- global objCurrentEnvironment
- $objCurrentEnvironment record_test NOTE $szMsg
- }
-
- public method unresolved {szMsg} {
- global objCurrentEnvironment
- incr iUnresolved
- $objCurrentEnvironment record_test UNRESOLVED $szMsg
- }
- public method untested {szMsg} {
- global objCurrentEnvironment
- incr iUntested
- $objCurrentEnvironment record_test UNTESTED $szMsg
- }
- public method unsupported {szMsg} {
- global objCurrentEnvironment
- incr iUnsupported
- $objCurrentEnvironment record_test UNSUPPORTED $szMsg
- }
-
- private method setResult {} {
- if {$iUnresolved || \
- $iError || $iCrashed || \
- ($iWarning > [namespace eval ::BlueGnu { \
- set warning_threshold}] && \
- 0 < [namespace eval ::BlueGnu { \
- set warning_threshold}])} {
- set eResult UNRESOLVED
- } elseif {$iUntested} {
- set eResult UNTESTED
- } elseif {$iUnsupported} {
- set eResult UNSUPPORTED
- } elseif {($iPassed > 0 || $iXFailed > 0) && \
- $iFailed == 0 && $iXPassed == 0} {
- set eResult "PASSED"
- } elseif {$iFailed || $iXPassed} {
- set eResult "FAILED"
- } elseif {$iPassed == 0 && $iXPassed && \
- $iFailed == 0 && $iXFailed && $iCrashed == 0 && \
- $iError == 0 && $iWarning == 0} {
- set eResult ACTIVATED
- } else {
- set eResult UNKNOWN
- }
- }
-
- public method getResult {} {
- setResult
- return $eResult
- }
-
- public method tool {} {
- return $szTool
- }
-
- public method scriptName {} {
- return $szScriptName
- }
-
- public method << {} {
- if 0 {
- lappend lResult [list ID $szID]
- lappend lResult [list name $szName]
- lappend lResult [list tool $szTool]
- lappend lResult [list type $eType]
- lappend lResult [list result $eResult]
- lappend lResult [list root $szRoot]
- lappend lResult [list script $szScriptName]
- lappend lResult [list arguments $lArguments]
- lappend lResult [list host $szHostName]
-
- return $lResult
- } else {
- eval [info function Common::<< -body]
- }
- }
-
- public method runtest {} {
- global objCurrentEnvironment
- setResult
-
- if {$bTestCase} {
- ::BlueGnu::clone_output "####### Begin test case :\
- >$szTestCase<"
- debug { [scriptName]\n \
- [name]=[arguments]}
- } else {
- ::BlueGnu::clone_output "####### Begin test script :\
- >$szID<"
- debug { [scriptName]\n \
- [name]=[arguments]}
- }
- verbose { Full Pathname : $szScriptName} 1
- debug {=== Running test in $this: $szScriptName} 3
- debug {[join [<<] "\n"]} 9
- catch {debug {Global Default Test Directory is\
- >[uplevel #0 set szCurrentTestDirectory]<}}
- catch {debug {Default Test Directory is >$szTool<}}
-
- if [catch {
- uplevel #0 set szCurrentTestDirectory "$szTool"
- uplevel #0 lappend lTool {$szCurrentTestDirectory}
- uplevel #0 set objCurrentTest $this
- uplevel #0 lappend lTestName {$objCurrentTest}
- uplevel 1 variable bTestCase $bTestCase
- uplevel 1 variable szTestCase \"$szTestCase\"
- uplevel 1 variable szTestCaseID \"$szTestCaseID\"
- uplevel 1 variable szTestCaseArgs \"$szTestCaseArgs\"
- uplevel 1 variable iArgs [llength $lArguments]
- uplevel 1 variable lArgs [concat {[list} $lArguments {]}]
- uplevel 1 variable szID $szID
- uplevel 1 variable szScriptName $szScriptName
- uplevel 1 variable szName $szName
- uplevel 1 variable szTool $szTool
- } szErrMsg] {
- debug {Error Msg:>>>$szErrmsg<<<} 0
- }
- if {[catch {uplevel 1 source $szScriptName} szErrMsg]} {
- global errorInfo errorCode
- crashed ">$szErrMsg<\
- \n in script: >$szScriptName<\
- \n errorInfo: >$errorInfo<\
- \n errorCode: >$errorCode<"
- }
- setResult
- $objCurrentEnvironment reportTestResult $eResult
-
- uplevel #0 {set lTestName [lreplace $lTestName end end]}
- uplevel #0 {set objCurrentTest [lrange $lTestName end end]}
- uplevel #0 {set lTool [lreplace $lTool end end]}
- uplevel #0 {set szCurrentTestDirectory [lrange $lTool end end]}
-
- catch {debug {Default Test Directory is >$szTool<} 3}
- catch {debug {Global Default Test Directory is\
- >[uplevel #0 set szCurrentTestDirectory]<} 3}
- debug {=== Done with test in $this: $szScriptName ($bTestCase)} 3
- if {$bTestCase} {
- ::BlueGnu::clone_output "####### End test case :\
- >$szTestCase<"
- } else {
- ::BlueGnu::clone_output "####### End test script :\
- >$szID<"
- }
- return $this
- }
- }
-
- class Queue {
- inherit Common
-
- protected variable lTestNames
-
- constructor {} {
- set lTestNames {}
- }
-
- public method append args {
- set testName [join $args]
- debug { queue appending >$testName<} 3
- lappend lTestNames $testName
- debug { DONE} 3
- }
-
- public method prepend args {
- #set testName [join $args]
- debug {Queue::prepend $args} 3
- foreach arg $args {
- debug { append >$arg< to comList} 3
- lappend comList $arg
- }
- debug { queue prepending comList: >$comList<} 3
- debug { [llength $comList] elements in comList} 3
- #set lTestNames [linsert $lTestNames 0 "$testName"]
- debug { [llength $lTestNames] elements in lTestNames} 3
- set lTestNames [concat $comList $lTestNames]
- debug { [llength $lTestNames] elements in lTestNames} 3
- debug { DONE} 3
- }
-
- public method pop {} {
- if {[llength $lTestNames] == 0} {
- return -code error -errorinfo "Empty Queue" {}
- }
- if {[llength $lTestNames] == 1} {
- set testName [lindex $lTestNames 0]
- set lTestNames {}
- return $testName
- #return -code error $testName
- }
- set testName [lindex $lTestNames 0]
- set lTestNames [lrange $lTestNames 1 end]
- return $testName
- }
-
- public method << {} {
- #lappend lResult [list tests $lTestNames]
-
- #return $lResult
- eval [info function Common::<< -body]
- }
- }
-
- class Environment {
- inherit Common
-
- protected variable szName "Default"
-
- protected variable iPassCnt 0
- protected variable iFailCnt 0
- protected variable iXPassCnt 0
- protected variable iXFailCnt 0
- protected variable iUntestedCnt 0
- protected variable iUnresolvedCnt 0
- protected variable iUnsupportedCnt 0
- protected variable iCrashedCnt 0
- protected variable iErrorCnt 0
- protected variable iWarningCnt 0
- protected variable iCnt 0
-
- protected variable iWarningThreshold 0
- protected variable iErrorThreshold 0
-
- protected variable bXFailFlag 0
- protected variable bExitStatus 0
-
- protected variable eResult UNKNOWN
- protected variable iUntested 0
- protected variable iUnsupported 0
- protected variable iUnresolved 0
- protected variable iPassed 0
- protected variable iFailed 0
-
-
- protected variable ENV
- protected variable bSaved 0
- common defaultEnvironment [list PATH FPATH \
- BLUEGNULIB TESTSUITEROOT TESTSETS TMPDIR \
- DISPLAY EDITOR EMACSFONT HOME LANG LOGIN LOGNAME SHELL \
- TERM USER WINDOWID DEBUG LPDEST \
- ORGANIZATION OSTYPE PAGER \
- PARM_SEARCH_PATH \
- ]
-
- constructor {args} {
- debug {Level in Constructor: [info level]} 9
- eval [info function Common::constructor -body]
- setResult
- }
-
- destructor {
- global objCurrentTarget
- debug {******* [info class]::destructor} 3
-
- ::BlueGnu::clone_output "******* Result :\
- [format "%-12s" $eResult]\
- for test session : >$szName<"
- switch $eResult {
- PASSED {
- ::BlueGnu::clone_output " Statistics :\
- $iPassed (PASS)"
- ::BlueGnu::clone_output "******* Cumulative statistics\
- for all test script!"
- ::BlueGnu::clone_output " Statistics Totals :\
- $iPassCnt (PASS),\
- $iXFailCnt (XFAIL)"
- if {$iUntested} {
- ::BlueGnu::clone_output " :\
- $iUntested (UNTESTED)"
- }
- if {$iWarningCnt} {
- ::BlueGnu::clone_output " :\
- $iWarningCnt (WARNING)"
- }
- }
- UNKNOWN -
- default {
- ::BlueGnu::clone_output " Statistics :\
- $iPassed (PASS)"
- ::BlueGnu::clone_output " :\
- $iFailed (FAIL)"
- if {$iUntested} {
- ::BlueGnu::clone_output " :\
- $iUntested (UNTESTED)"
- }
- if {$iUnresolved} {
- ::BlueGnu::clone_output " :\
- $iUnresolved (UNRESOLVED)"
- }
- if {$iUnsupported} {
- ::BlueGnu::clone_output " :\
- $iUnsupported (UNSUPPORTED)"
- }
- ::BlueGnu::clone_output "******* Cumulative statistics\
- for all test script!"
- ::BlueGnu::clone_output " Statistics Totals :\
- $iPassCnt (PASS),\
- $iXFailCnt (XFAIL)"
- ::BlueGnu::clone_output " :\
- $iFailCnt (FAIL),\
- $iXPassCnt (XPASS)"
- if {$iUntestedCnt} {
- ::BlueGnu::clone_output " :\
- $iUntestedCnt (UNTESTED)"
- }
- if {$iUnresolvedCnt} {
- ::BlueGnu::clone_output " :\
- $iUnresolvedCnt (UNRESOLVED)"
- }
- if {$iUnsupportedCnt} {
- ::BlueGnu::clone_output " :\
- $iUnsupportedCnt (UNSUPPORTED)"
- }
- if {$iCrashedCnt} {
- ::BlueGnu::clone_output " :\
- $iCrashedCnt (CRASHED)"
- }
- if {$iErrorCnt} {
- ::BlueGnu::clone_output " :\
- $iErrorCnt (ERROR)"
- }
- if {$iWarningCnt} {
- ::BlueGnu::clone_output " :\
- $iWarningCnt (WARNING)"
- }
- }
- }
- if {$::BlueGnu::errcnt} {
- ::BlueGnu::clone_output "####### Encountered\
- $::BlueGnu::errcnt System Errors!"
- }
- ::BlueGnu::clone_output "###########################\n"
- }
-
- public method name {} {
- return $szName
- }
-
- public method record_test {type message} {
- debug {******* ${this}::record_test \n \
- $type $message} 3
- if {$iWarningThreshold > 0 && \
- $iWarningCnt >= $iWarningThreshold \
- || \
- $iErrorThreshold > 0 && \
- $iErrorCnt >= $iErrorThreshold} {
- # Reset these first to prevent infinite recursion.
- set iWarningCnt 0
- set iErrorCnt 0
- ::unresolved $message
- return
- }
-
- debug { switching on type >$type<}
- switch $type {
- PASS {
- incr iPassCnt
- }
- FAIL {
- incr iFailCnt
- set bExitStatus 1
- }
- XPASS {
- incr iXPassCnt
- }
- XFAIL {
- incr iXFailCnt
- }
- UNTESTED {
- incr iUntestedCnt
- }
- UNRESOLVED {
- incr iUnresolvedCnt
- }
- UNSUPPORTED {
- incr iUnsupportedCnt
- }
- ERROR {
- incr iErrorCnt
- }
- CRASHED {
- incr iCrashedCnt
- }
- NOTE {
- }
- WARNING {
- incr iWarningCnt
- }
- default {
- debug {record_test called with bad type >$type<} -1
- set iErrorCnt 0
- return
- }
- }
-
- ::BlueGnu::clone_output "$type: $message"
-
- # reset variables here
- namespace eval ::BlueGnu {
- set xfail_flag 0
- set xfail_prms {}
- }
- }
-
- private method setResult {} {
- if {$iUnresolved} {
- set eResult UNRESOLVED
- } elseif {$iPassed > 0 && $iFailed == 0} {
- set eResult "PASSED"
- } elseif {$iFailed} {
- set eResult "FAILED"
- } elseif {$iPassed == 0 && $iFailed == 0 && \
- $iUntested && $iUnsupported == 0 && \
- $iUnresolved == 0} {
- set eResult ACTIVATED
- } else {
- set eResult UNKNOWN
- }
- }
-
- public method reportTestResult {eTestResult} {
- switch $eTestResult {
- "PASSED" {
- incr iPassed
- }
- "FAILED" {
- incr iFailed
- }
- "UNSUPPORTED" {
- incr iUnsupported
- }
- "UNTESTED" {
- incr iUntested
- }
- "UNRESOLVED" {
- incr iUnresolved
- }
- }
- setResult
- }
-
- public method saveEnv {} {
- global env
-
- set bSaved 1
- foreach index [lsort [array names env]] {
- debug {ENV($index) := $env($index)} 5
- #set ENV($index) $env($index)
- array set ENV [list $index $env($index)]
- }
- }
-
- public method clearEnv {} {
- global env
-
- set bSaved 1
- #debug {removing ENV} 5
- #catch {unset ENV}
- foreach index [array names env] {
- debug {removing env($index) := $env($index)} 5
- if {0 > [lsearch -exact $defaultEnvironment $index]} {
- debug { removed} 5
- unset env($index)
- } else {
- debug { kept} 5
- if {[string compare $index PATH] == 0} {
- # Do not touch PATH
- #set env(PATH) \
- "/etc:/usr/lib:/usr/ucb:/bin:/usr/bin:/usr/bin/X11:/usr/lpp/X11/Xamples/bin:/usr/local/bin"
- }
- #set ENV($index) $env($index)
- }
- }
- }
-
- public method restoreEnv {} {
- global env
-
- if {$bSaved} {
- catch {unset env}
- foreach index [array names ENV] {
- debug {env($index) := $ENV($index)} 5
- #set ENV($index) $env($index)
- array set env [list $index $ENV($index)]
- }
- } else {
- debug {Environment had not been saved!}
- }
- }
-
- public method runTest args {
- global nspTestSuite
- debug {======= runTest $args} 3
-
- set iRuntest 0
- set elResult [list]
-
- set iRun 0
- foreach arg $args {
- debug {======= runTest $arg} 3
- incr iRun
-
- # Create name for namespace for the test
- # and check if already exist
- #
- set szRuntest runtest$iRuntest
- set namespaceCurrent [namespace current]
- debug { szRuntest: >$szRuntest<} 4
- debug { namespace current : >$namespaceCurrent<} 4
- debug { namespace current children:\
- >[namespace children $namespaceCurrent]<} 4
- while {[string compare \
- [namespace children $namespaceCurrent \
- ${namespaceCurrent}::$szRuntest] ""] != 0} {
- incr iRuntest
- set szRuntest runtest$iRuntest
- }
- # now we have a unique namespace name for the running
- # of the test
- #
- debug { runTest namespace: >$szRuntest<} 4
- set szScript $arg
- # create a Test Class object
- if {! [catch {::BlueGnu::Test [${nspTestSuite}::autoTest] \
- $szScript} testObject]} {
- if [catch {
- uplevel #0 set objCurrentTest \
- [namespace current]::$testObject
- debug {[join [$testObject <<] "\n"]} 9
- namespace eval $szRuntest {
- if [catch {[uplevel set testObject] runtest} \
- szErrMsg] {
- uplevel set szErrMsg "\{$szErrMsg\}"
- uplevel {
- global errorInfo errorCode
- record_test CRASHED ">$szErrMsg<\
- \n in script: >$szScript<\
- \n errorInfo: >$errorInfo<\
- \n errorCode: >$errorCode<"
- }
- }
- }
- debug {[join [$testObject <<] "\n"]} 9
- uplevel "lappend elResult [$testObject getResult]"
- delete object $testObject
- } szErrMsg] {
- global errorInfo errorCode
- record_test CRASHED ">$szErrMsg<\
- \n in script: >$szScript<\
- \n errorInfo: >$errorInfo<\
- \n errorCode: >$errorCode<"
- }
- } else {
- global errorInfo errorCode
- record_test CRASHED ">$testObject<\
- \n in script: >$szScript<\
- \n errorInfo: >$errorInfo<\
- \n errorCode: >$errorCode<"
- }
- namespace delete $szRuntest
- uplevel #0 {debug {argv: [set argv]} 3}
- }
- if {$iRun == 0} {
- warning "No tests have been passed to runTest method!"
- }
- return $elResult
- }
-
- public method << {} {
- debug {in $this method} 5
- eval [info function Common::<< -body]
- #lappend lResult [list ENV [array get ENV]]
- }
- }
-
- # The following is a class definition for the target implementation
- # in DejaGnu (see lib/target.exp for more detail)
- #
- class Target {
- inherit Common
-
- protected variable szID
- protected variable szName
- protected variable szApplication
- protected variable objEnvironment
- protected variable objQueue
-
- protected variable connect
- protected variable target
- protected variable serial
- protected variable netport
- protected variable baud
- protected variable X10
- protected variable ioport
-
- protected variable fileid
- protected variable prompt
- protected variable abbrev
- protected variable config
- protected variable cflags
- protected variable ldflags
-
- protected variable X
-
- # a hairy pattern to recognize text
- common text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]"
-
-
- constructor {args} {
- eval [info function Common::constructor -body]
- }
-
- destructor {
- delete object $objQueue
- }
-
- public method name {args} {
- if {[llength $args] == 0} {
- return $szName
- } else {
- set szName [lindex $args 0]
- }
- }
-
- public method ID {args} {
- if {[llength $args] == 0} {
- return $szID
- } else {
- set szID [lindex $args 0]
- }
- }
-
- public method << {} {
- eval [info function Common::<< -body]
- }
-
- public method environment {} {
- return $objEnvironment
- }
-
- public method start {} {
- if {[string length [uplevel #0 info procs ${szID}_start]] != 0} {
- uplevel #0 ${szID}_start
- }
- }
-
- public method load {args} {
- if {[string length [uplevel #0 info procs ${szID}_load]] != 0} {
- eval uplevel #0 ${szID}_load $args
- }
- }
-
- public method exit {} {
- if {[string length [uplevel #0 info procs ${szID}_exit]] != 0} {
- uplevel #0 ${szID}_exit
- }
- }
-
- public method version {} {
- if {[string length [uplevel #0 info procs ${szID}_version]] != 0} {
- uplevel #0 ${szID}_version
- }
- }
-
- public method runTests {} {
- debug {======= ${this}::runTest} 3
- set elResult [list]
- # if an application has been defined we run all the test
- # inside that application
- #
- if {[string compare [info variable szApplication] ""] != 0 && \
- [string compare [info variable szApplication -value] \
- "<undefined>"] != 0} {
- debug {Application specified >[info variable \
- szApplication -value]<}
- # build argument list
- debug {>>[<<]<<}
- } else {
- # We just run all the tests in the currently running
- # [incr Tcl/?Expect?] interpreter.
- #
- # set the current Queue and Environment
- #
- uplevel #0 set objCurrentQueue [infoWhich $objQueue]
- uplevel #0 set objCurrentEnvironment \
- [infoWhich $objEnvironment]
- #
- # Pop a test from the queue and run it in the environment
- ::BlueGnu::clone_output "###########################"
- ::BlueGnu::clone_output "####### Begin test session:\
- [[infoWhich $objEnvironment] name] >$objEnvironment<"
- while {! [catch {$objQueue pop} T]} {
- debug {test: $T} 3
- set elResult [$objEnvironment runTest $T]
- }
- ::BlueGnu::clone_output "####### End test session :\
- [[infoWhich $objEnvironment] name]"
- }
- return $elResult
- }
-
- public method queue {function element} {
- switch $function {
- append {
- $objQueue append $element
- }
- prepend {
- $objQueue prepend $element
- }
- }
- }
- }
-
- class Target2 {
- inherit Target
-
- protected variable XYZ
-
- constructor {args} {
- eval [info function Common::constructor -body]
- }
-
- public method << {} {
- eval [info function Common::<< -body]
- }
- }
-
-
- class DejaGnu {
- inherit Environment
-
- constructor {} {
- debug {Level in Constructor DejaGnu: [info level]} 9
- uplevel #0 {debug {argc = $argc: $argv} 9}
- # source always in global space
- #
- uplevel #0 source {$env(BLUEGNULIBS)/dejagnu.tcl}
- }
-
- destructor {
- #####################################################################
- # This comes from the original runtest
- # all done, cleanup
- #
- uplevel #0 {
- if { [info procs ${tool}_exit] != "" } {
- if {[catch "${tool}_exit" tmp]} {
- # ??? We can get away with calling `warning'
- # here without ensuring
- # `warncnt' isn't changed because we're about to exit.
- warning "${tool}_exit failed:\n$tmp"
- }
- }
- log_summary
- }
- }
-
-
- public method runTest {args} {
- global nspTestSuite
-
- foreach arg $args {
- debug {******* DejaGnu running test: >$arg<}
- debug {set szTestName \[Test \[${nspTestSuite}::autoTest\] $arg\]} 3
- debug {set testName >[${nspTestSuite}::autoTest]<} 3
- uplevel #0 set szTestName [Test [${nspTestSuite}::autoTest] $arg]
- uplevel #0 {
- debug $szTestName 3
- debug [join [$szTestName <<] "\n"] 5
- set test_name {[$szTestName scriptName]}
- catch {unset tmp}; set tmp {}
- foreach arg [$szTestName arguments] {
- lappend tmp [join $arg "="]
- }
- set runtests [list [$szTestName name] $tmp]
- debug {args = >[$szTestName arguments]<} 3
- source [$szTestName scriptName]
- catch {eval unset [info vars __*]}
- }
- }
- }
- }
-
- class DejaGnu2 {
- inherit DejaGnu
-
- protected variable currentTool
-
- constructor {} {
- debug {Level in Constructor DejaGnu2: [info level]} 9
- set currentTool {}
- uplevel #0 {debug {argc = $argc: $argv} 9}
- # source always in global space
- #
- uplevel #0 source {$env(BLUEGNULIBS)/dejagnu2.tcl}
- }
-
- public method tool {args} {
- if {[llength $args] == 1} {
- set currentTool [lindex $args 0]
- }
- return $currentTool
- }
- }
-
- class Benchmark {
- protected variable bResult 0
- protected variable DATA
- protected variable FORMAT
- protected variable ARG
-
- protected constructor {args} {
- debug {======= Constructing class [info class] =======} 3
- debug {======= ::BlueGnu::Benchmark::constructor $args} 4
- set i 0
- foreach arg $args {
- debug { ARG($i): >$arg<} 5
- set ARG($i) [split $arg "="]
- incr i
- }
- }
- protected destructor {
- debug {======= [info class]::destructor} 3
- }
-
- protected method benchmark {benchmarkFunction args} {
- warning "Method >benchmark< has not been implemented for\
- Class >[info class]<"
- return $bResult
- }
-
- protected method warningNoBenchmarkArguments {} {
- warning "NO argument have been supplies for\n the benchmark\
- method in class [info class]"
- }
- protected method warningNoBenchmarkFunction {} {
- warning "NO benchmark function >[uplevel set benchmarkFunction]<\
- defined for\n the benchmark method in class [info class]"
- }
- }
-
- class Error {
- private variable _errorCode
- private variable _errorMsg
- private variable _errorInfo
-
- public constructor {errorCode errorMsg errorInfo} {
- set _errorCode $errorCode
- set _errorMsg $errorMsg
- set _errorInfo $errorInfo
- }
-
- public method errorCode {} {
- return $_errorCode
- }
- public method errorMsg {} {
- return $_errorMsg
- }
- public method errorInfo {} {
- return $_errorInfo
- }
- public method why {} {
- return $_errorMsg
- }
- public method verboseWhy {} {
- return $_errorInfo
- }
- }
-}
generated by cgit v1.1 at 2024-07-17 00:53:43 +0000