testSessionApplication.itcl [plain text]
#
# 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
}
}
}