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, 314 insertions, 0 deletions
diff --git a/contrib/bluegnu2.0.3/lib/testSessionApplication.itcl b/contrib/bluegnu2.0.3/lib/testSessionApplication.itcl new file mode 100644 index 0000000..3d57722 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/testSessionApplication.itcl @@ -0,0 +1,314 @@ +# +# 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 + } + } +} |