path: root/contrib/bluegnu2.0.3/lib/testSessionApplication.itcl

#
# 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
	}
    }
}