diff options
Diffstat (limited to 'contrib/bluegnu2.0.3/lib/testSessionApplication.itcl')
| -rw-r--r-- | contrib/bluegnu2.0.3/lib/testSessionApplication.itcl | 314 |
1 files changed, 0 insertions, 314 deletions
diff --git a/contrib/bluegnu2.0.3/lib/testSessionApplication.itcl b/contrib/bluegnu2.0.3/lib/testSessionApplication.itcl deleted file mode 100644 index 3d57722..0000000 --- a/contrib/bluegnu2.0.3/lib/testSessionApplication.itcl +++ /dev/null @@ -1,314 +0,0 @@ -# -# This file defines the Application Class -# - -source $env(BLUEGNULIB)/testSessionFramework.itcl -source $env(BLUEGNULIB)/testSessionClasses.itcl - -namespace eval ::BlueGnu { - class Application { - protected variable szName "Default" - protected variable lTargets {} - protected variable lTests - protected variable szCurrentTarget - protected variable objCurrentTarget - protected variable objEnvironment - protected variable szOutDir - - constructor {args} { - debug {======= Doing Application construction} 3 - set szOutDir "..." - 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 { - error "$var does not exists in Class [info class]" - } - } - } - - destructor { - } - - public method execute {} { - debug {======= Starting with Execution of the Application} 3 - debug { list of indexes for lTests is [array names lTests]} 4 - set iTarget 0 - set objEnvironment [uplevel #0 \ - "::BlueGnu::Environment #auto \ - szName=$szName"] - debug { objEnvironment = >$objEnvironment<} 3 - debug { +++ [infoWhich $objEnvironment] +++} 4 - debug { === [::itcl::find objects] ===} 4 - uplevel #0 set objCurrentEnvironment $objEnvironment - foreach target $lTargets { - set szTargetName [lindex [split $target "="] 0] - open_logs $szTargetName - incr iTarget - # set current Test Suite Namespace - uplevel #0 set nspTestSuite "::TestSuite[format %.5d $iTarget]" - debug { Processing target: >$target< in Test Suite\ - [uplevel set nspTestSuite]} 3 - namespace eval [uplevel set nspTestSuite] { - debug { Context is >[namespace current]<} 3 - variable iTestNr 0 - proc autoTest {} { - variable iTestNr - - incr iTestNr - debug {iTestNr = $iTestNr} 5 - debug {namespace current = >[namespace current]<} 5 - debug {format = >T[format %.5d $iTestNr]<} 5 - return [namespace current]::T[format %.5d $iTestNr] - } - - set target [uplevel set target] - debug { In namespace eval [namespace current]\ - for target: >$target<} 3 - if {! [catch { - if {[string length $target] == 0} { - # Create a default Target Object - # - debug { Create a default Target Object} 3 - uplevel #0 set objCurrentTarget \ - [infoWhich \ - [::BlueGnu::Target #auto \ - szID=default \ - szName=default \ - objQueue=[infoWhich [::BlueGnu::Queue #auto]] \ - objEnvironment=[uplevel set objEnvironment]]] - } else { - # Call the Target Procedure - # This procedure should return a Target Object. - # Arguments are passed to this procedure. - debug { Create target: >$target<} 3 - set list [split $target "="] - uplevel #0 set objCurrentTarget \ - [infoWhich \ - [eval [lindex $list 0] \ - [join [lrange $list 1 end] "="] \ - objEnvironment=[uplevel set objEnvironment]]] - } - } szErrMsg]} { - debug { Current Target is\ - >[set target \ - [uplevel #0 set objCurrentTarget]]<} 3 - - debug { Working with target index\ - [uplevel set iTarget]} 4 - if {[uplevel {info exists lTests($iTarget)}]} { - foreach test [uplevel {set lTests($iTarget)}] { - debug { test: $test} 3 - $target queue append $test - } - } - $target start - $target runTests - $target exit - - # report results of the testing - # - debug { #### All Objects: [::itcl::find objects]} 3 - foreach T [lsort [::itcl::find objects T*]] { - debug { #### Deleting Object $T\ - ([$T info class])} 0 - delete object $T - } - # remove constructed objects - # - debug { Removing Target Class Object $target} 3 - delete object $target - } else { - global errorCode errorInfo - perror "Couldn't create target >$target<!\ - \n May be no procedure with name\ - >$target< defined!\ - \n errorMsg : >$szErrMsg<\ - \n errorInfo: >$errorInfo<\ - \n errorCode: >$errorCode<" - debug { error info:\n$errorInfo} 3 - } - } - namespace delete [uplevel set nspTestSuite] - close_logs - } - debug { objects: >[::itcl::find objects]<} 4 - debug {####### deleting Object Environment >$objEnvironment<} 4 - delete object $objEnvironment - } - - public method processArguments {arguments} { - upvar $arguments argv - global szCurrentTestDirectory - - set state NORMAL - set iTarget 0 - foreach arg $argv { - switch -regexp -- $arg { - {^-a(l(l)?)?$} { - debug { all_flag set to TRUE} 4 - set ::BlueGnu::all_flag 1 - } - {^-o(u(t(d(i(r)?)?)?)?)?$} { - debug { Output Directory is next argument} 4 - set state OUTDIR - } - {^--o(u(t(d(i(r)?)?)?)?)?=.*} { - set components [split $arg "="] - debug { Processing Output Directory >$arg<} 4 - set szOutDir [lindex $components 1] - set state NORMAL - } - {^-[-]?t(a(r(g(e(t)?)?)?)?)?([=].*|$)} { - set components [split $arg "="] - if {[llength $components] == 1} { - debug { Target is next argument} 4 - set state TARGET - } else { - debug { Processing Target >$arg<} 4 - setTarget iTarget \ - [join [lrange $components 1 end] "="] - set state NORMAL - } - } - default { - debug { Processing argument: >$arg<} 3 - switch $state { - OUTDIR { - set szOutDir $arg - set state NORMAL - } - TARGET { - setTarget iTarget $arg - set state NORMAL - } - NORMAL { - set components [split $arg "="] - regexp {([^[]*)(.*)} [lindex $components 0] \ - dummy szFileName szCaseArgs - append szCaseArgs "=[join \ - [lrange $components 1 end] "="]" - debug { arg: >$arg<} 3 - debug { components: >$components<} 3 - debug { case+args: >$szCaseArgs<} 3 - debug { Test Script: >$szFileName<} 3 - debug { : >$szCurrentTestDirectory<} 3 - 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 - if {! [info exists szCurrentTarget]} { - setTarget iTarget {} - } - lappend lTests($iTarget) \ - [file join \ - $szCurrentTestDirectory \ - $arg] - debug { Appended test:\ - >[file join \ - $szCurrentTestDirectory \ - $arg]<!} 3 - } 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 - if {! [info exists\ - szCurrentTarget]} { - setTarget iTarget {} - } - lappend lTests($iTarget) \ - $test$szCaseArgs - debug { Appended test:\ - >$test$szCaseArgs<!!} 2 - } else { - warning "Test >$test< can't\ - be found" - } - } - } else { - perror "$szFileName is not a test!\ - Does not exists!" - } - } - } - } - } - } - debug { ==== Found tests:} 3 - foreach index [lsort [array names lTests]] { - debug { lTests($index) = $lTests($index)} 4 - } - debug { Targets are: $lTargets} 4 - } - private method setTarget {index target} { - upvar $index iTarget - - incr iTarget - if {[string length $target] == 0} { - set szCurrentTarget "Default" - lappend lTargets $szCurrentTarget - debug { Default Current Target} 3 - } else { - set szCurrentTarget $target - lappend lTargets $szCurrentTarget - debug { Current target: >$szCurrentTarget<} 3 - } - debug { Found target >$szCurrentTarget<} 3 - } - - private method open_logs {target} { - global env - - set target [string trim $target] - if {[string compare $szOutDir "..."] == 0} { - debug { No Output directory defined, creating one} 3 - set szOutDir \ - "logs/$env(USER)_${target}_[exec date +%Y%m%d]_" - set szI [format "%.4d" [set i 0]] - while {[file isdirectory $szOutDir$szI]} { - set szI [format "%.4d" [incr i]] - } - set szOutDir $szOutDir$szI - } - if {! [file isdirectory $szOutDir]} { - exec mkdir -p $szOutDir - } - if {[string length $target] == 0} { - set szTool testrun - } else { - set szTool $target - } - catch "exec rm -f $szOutDir/$szTool.sum" - namespace eval ::BlueGnu \ - "set ::BlueGnu::sum_file [open "$szOutDir/$szTool.sum" w]" - puts $::BlueGnu::sum_file "# $szOutDir/$szTool.sum" - catch "exec rm -f $szOutDir/$szTool.log" - log_file -a "$szOutDir/$szTool.log" - send_log "# $szOutDir/$szTool.log\n" - debug { Opening log and summary files in $szOutDir} 3 - } - private method close_logs {} { - } - public method outDir {} { - return $szOutDir - } - } -} |