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

#
#
#
#
# unknown -- called by expect if a proc is called that doesn't exist
#

# Set auto_load to take BLUEGNULIB first on search path
#
set auto_path "$env(BLUEGNULIB) $auto_path"

# find tclIndex file in the test suite directory structure
# $env(TESTSUITEROOT) and in the path up to the root
#
if {! [info exists env(TESTSUITEROOT)]} {
    set env(TESTSUITEROOT) [exec /bin/sh -c pwd]
}
set PWD $env(TESTSUITEROOT)

if {[info exists env(TESTSETS)]} {
    if {[lsearch -exact [split $env(TESTSETS) ":"] $PWD] < 0} {
	set env(TESTSETS) $PWD:$env(TESTSETS)
    }
} else {
    set env(TESTSETS) $PWD
}
cd $PWD


# First thing to do is calculate the verbose level and the debug flag
# as well as the definition of the associated procedures:
#      verbose and debug.
#
# Check the Debug level
if [info exists env(DEBUG)] {
    switch -regexp [string toupper $env(DEBUG)] {
	1 - ^T(R(U(E)?)?)?$ - ^Y(E(S)?)?$ {
	    set bDebug 1
	}
	default {
	    set bDebug 0
	}
    }
} else {
    set bDebug 0
}

# Calculate verbose level
# Complete a first path over the argument list
#    Calculate the Verbose Level
set verbose 0
foreach __arg $argv {
    switch -regexp -- $__arg {
	{^-[-]?v(e(r(b(o(s(e)?)?)?)?)?)?$} {
	    incr verbose
	}
	default {
	    lappend __lArgs $__arg
	}
    }
}
if {[catch {set argv $__lArgs}]} {
    set argv {}
}

# Define the procedures: verbose & debug
#
# verbose [-n] [-log] [--] message [level]
#
# Print MESSAGE if the verbose level is >= LEVEL.
# The default value of LEVEL is 1.
# "-n" says to not print a trailing newline.
# "-log" says to add the text to the log file even if it won't be printed.
# Note that the apparent behaviour of `send_user' dictates that if the message
# is printed it is also added to the log file.
# Use "--" if MESSAGE begins with "-".
#
# This is defined here rather than in framework.exp so we can use it
# while still loading in the support files.
#
proc verbose {args} {
    debug {======= verbose $args} 3
    global verbose

    set newline 1
    set logfile 0

    set i 0
    if {[string index [lindex $args 0] 0] == "-"} {
	for { set i 0 } { $i < [llength $args] } { incr i } {
	    if { [lindex $args $i] == "--" } {
		incr i
		break
	    } elseif { [lindex $args $i] == "-n" } {
		set newline 0
	    } elseif { [lindex $args $i] == "-log" } {
		set logfile 1
	    } elseif { [string index [lindex $args $i] 0] == "-" } {
		return [::BlueGnu::clone_output "ERROR: verbose:\
			illegal argument: [lindex $args $i]"]
	    } else {
		break
	    }
	}
    }
    if {[llength $args] == $i} {
	return [::BlueGnu::clone_output "ERROR: verbose: nothing to print"]
    }


    set level 1
    if {[llength $args] == $i + 2} {
	if [catch {set level [expr [lindex $args [expr $i+1]]]} szErrMsg] {
	    return [::BlueGnu::clone_output "ERROR: verbose: level number\
		    >$szErrMsg<"]
	}
    } elseif {[llength $args] > $i + 2} {
	return [::BlueGnu::clone_output "ERROR: verbose: Too many arguments"]
    }
    set message [lindex $args $i]
    
    if {$level <= $verbose} {
	# There is no need for the "--" argument here, but play it safe.
	# We assume send_user also sends the text to the log file (which
	# appears to be the case though the docs aren't clear on this).
	if 0 {
	    if {[string compare \
		    [namespace eval ::BlueGnu \
		    {set ::BlueGnu::sum_file}] stdout] != 0} {
		set szCmd [list uplevel puts [namespace eval ::BlueGnu \
			{set ::BlueGnu::sum_file}]]
		lappend szCmd "\"$message\""
		debug {==## 1 >$szCmd<} 9
		if {[catch {eval $szCmd}]} {
		    puts [namespace eval ::BlueGnu \
			    {set ::BlueGnu::sum_file}] $message
		}
	    }
	}
	if [catch {set message \
		"[uplevel set __szTmp \"$message\"]"} szErrMsg] {
	    set message "$message == ERROR: >$szErrMsg<"
	}
	if {$newline} {
	    #append message "\n"
	}
	debug {$message} 0
	return [::BlueGnu::clone_output "$message"]
    } elseif {$logfile} {
	if [catch {set message \
		"[uplevel set __szTmp \"$message\"]"} szErrMsg] {
	    set message "$message == ERROR: >$szErrMsg<"
	}
	if {$newline} {
	    append message "\n"
	}
	debug {$message} 0
	return [send_log $message]
    }
    return ""
}

if {$bDebug} {
    proc debug {text {level 1}} {
	global verbose

	if {$level <= $verbose} {
	    set szCmd [list uplevel ::BlueGnu::clone_output]
	    set szA $level; set iMax [uplevel info level]
	    for {set i 0} {$i < $iMax} \
		    {incr i} {append szA ">"}
	    lappend szCmd "\"$szA$text\""
	    eval $szCmd
	}
    }
} else {
    proc debug {text {level 1}} {
    }
}

# This procedure will find a file in the directory structure
# any where below the current working directory
# any where on the search path
# or up the directory tree
#
proc locateFile {szFileName {szSubDirectory "."}} {
    debug {======= locateFile $szFileName $szSubDirectory} 3
    global env
    # remove a trailing "/" from sub directory name
    regexp {(.*)/$} $szSubDirectory dummy szSubDirectory

    set newList {}
    set searchList {.}
    set tmpDir [pwd]
    while {[string compare [set dir [file dirname $tmpDir]] "/"] != 0} {
	lappend searchList $dir
	set tmpDir $dir
    }
    foreach dir [split $env(TESTSETS) ":"] {
	lappend searchList $dir
    }
    foreach dirList $searchList {
	foreach test [searchForFile $szFileName $dirList $szSubDirectory] {
	    # only files that are readable and
	    # not a directory, symbolic link or device
	    # are added to the list
	    if {[file isfile $test] && [file readable $test]} {
		# add only if not already exists in list
		if {[lsearch -exact $newList $test] < 0} {
		    lappend newList $test
		}
	    }
	}
    }
    debug {======= returning newList: >$newList<} 4
    return $newList
}

proc locateDir {szFileName {szSubDirectory "."}} {
    debug {======= locateDir $szFileName $szSubDirectory} 3
    global env
    # remove a trailing "/" from sub directory name
    regexp {(.*)/$} $szSubDirectory dummy szSubDirectory

    set newList {}
    set searchList {.}
    set tmpDir [pwd]
    while {[string compare [set dir [file dirname $tmpDir]] "/"] != 0} {
	lappend searchList $dir
	set tmpDir $dir
    }
    foreach dir [split $env(TESTSETS) ":"] {
	lappend searchList $dir
    }
    foreach dirList $searchList {
	foreach test [searchForFile $szFileName $dirList $szSubDirectory] {
	    # only files that are directories
	    # are added to the list
	    if {[file isdirectory $test]} {
		# add only if not already exists in list
		if {[lsearch -exact $newList $test] < 0} {
		    lappend newList $test
		}
	    }
	}
    }
    debug {======= returning newList: >$newList<} 4
    return $newList
}

proc searchForFile {szFileName dirList szSubDirectory} {
    debug {======= searchForFile $szFileName $dirList $szSubDirectory} 3
    # find sub directory in or below the current working directory
    set szDirSrc ""
    foreach file [file split $szSubDirectory] {
	if {[string compare $file "."] == 0} {
	    if {! [info exists newList]} {
		set newList {}
	    }
	    continue
	} else {
	    foreach dir $dirList {
		catch {unset newList}
		foreach newDir [findFile $dir $file] {
		    lappend newList $newDir
		}
	    }
	}
	if {[catch {set dirList $newList}]} {
	    set dirList {}
	}
    }
    debug {        dirList = >$dirList<} 4
    set fileList {}
    foreach dir $dirList {
	set newList [findFile $dir $szFileName]
	if {[llength $newList] > 0} {
	    set fileList [concat $fileList $newList]
	}
    }
    debug {        fileList = >$fileList<} 4
    if {[llength $fileList] != 0} {
	# NO test found, next step in searching
	#return $fileList
    }

    set newList {}
    set PWD [pwd]
    foreach dir $fileList {
	debug {        dir = >$dir<} 4
	cd [file dirname $dir]
	lappend newList "[pwd]/[file tail $dir]"
	cd $PWD
    }

    debug {        newList = >$newList<} 4
    return $newList
}

proc findFile {szDirectory szFileName} {
    global locatedFile env

    debug {======= findFile $szDirectory $szFileName} 3
    if {! [info exists locatedFile($szDirectory/$szFileName)]} {
	if {[file readable $szDirectory/$szFileName]} {
	    set locatedFile($szDirectory/$szFileName) $szDirectory/$szFileName
	} else {
	    if {$szDirectory == "." || \
		    [lsearch -exact [split $env(TESTSETS) ":"] \
		    $szDirectory] >= 0} {
		set locatedFile($szDirectory/$szFileName) \
			[split [exec find $szDirectory -name $szFileName \
			-print] "\n"]
	    } else {
		return {}
	    }
	}
    }
    return $locatedFile($szDirectory/$szFileName)
}

# appendArguments
#
# This procedure will append the string pathed in arguments to every
# element of fileList
# return a list with the same number of element in which each
# element has the arguments appended
#
proc appendArguments {fileList arguments} {
    set newList {}
    debug {======= appendArguments $fileList $arguments} 3
    debug {        length argument list: >[llength $arguments]<} 4
    if {[string length $arguments] > 0} {
	foreach file $fileList {
	    regexp {([^[=]+)([[][^]]*[]])?(.*)} $file dummy szT szID szA
	    debug {dummy: >$dummy<} 4
	    debug {szT  : >$szT<} 4
	    if {[string length $szID] > 0} {
		#regexp {[[]([^]]+)[]]} $szID dummy szID
	    }
	    debug {szID : >$szID<} 4
	    if {[string length $szA] > 0} {
		regexp {=(.*)} $szA dummy szA
	    }
	    debug {szA  : >$szA<} 4
	    #set lFile [split $file "="]
	    if {[string length $szA] > 0} {
		set szSep " "
	    } else {
		set szSep "="
	    }
	    lappend newList ${file}${szSep}$arguments
	}
	return $newList
    }
    return $fileList
}

# appendTestCaseID
#
# This procedure will append the string pathed in arguments to every
# element of fileList
# return a list with the same number of element in which each
# element has the arguments appended
#
proc appendTestCaseID {fileList {szTestCaseID ""}} {
    set newList {}
    debug {======= appendTestCaseID $fileList >$szTestCaseID<} 3
    set bMultiFiles [expr [llength $fileList] > 1]
    set i 1
    foreach file $fileList {
	regexp {([^[=]+)([[][^]]*[]])?(.*)} $file dummy szT szID szA
	debug {dummy: >$dummy<} 4
	debug {szT  : >$szT<} 4
	if {[string length $szID] > 0} {
	    regexp {[[]([^]]+)[]]} $szID dummy szID
	}
	debug {szID : >$szID<} 4
	if {[string length $szA] > 0} {
	    #regexp {=(.*)} $szA dummy szA
	}
	debug {szA  : >$szA<} 4
	if {[string length $szID] > 0} {
	    set szID [string trim "${szID}${szTestCaseID}"]
	} else {
	    set szID ${szTestCaseID}
	}
	if {[llength [split $szID "="]] > 1} {
	    set szSep " "
	} else {
	    set szSep "="
	}
	if {[string length $szID] == 0} {
		lappend newList "${szT}$szA"
		continue
	}
	if {$bMultiFiles} {
	    set szI [format "${szSep}seqNr=%03d" $i]
	} else {
	    set szI ""
	}
	lappend newList "${szT}\[${szID}${szI}\]$szA"
	incr i
    }
    return $newList
}

# processArgs
#
# This procedure expect all optional arguments to be name=value pairs
# It will set all variable named to the value given within 
# the procedure body
# It will return an empty list or a list of all remaining not name=value
# pair in the argument list
#
proc processArgs {args} {
    debug {======= processArgs $args} 3

    set llArgs $args
    set args {}

    # set default errorCode=NONE
    uplevel set errorCode NONE
    # now process all name=value pair arguments
    ####### There may be a better way to do this see pre 8.0 code
    foreach lArgs $llArgs {
	foreach arg $lArgs {
	    set NVP [split $arg "="]
	    if {[llength $NVP] > 1} {
		debug {uplevel set [lindex $NVP 0] \
			[list [join [lrange $NVP 1 end] "="]]} 3
		uplevel set [lindex $NVP 0] \
			[list [join [lrange $NVP 1 end] "="]]
	    } else {
		lappend args $arg
	    }
	}
    }
    debug {        processArgs returns: $args} 3
    return $args
}

# processInternalArgs
#
# This procedure expect all optional arguments to be {name value} pairs
# It will set all variable named to the value given within 
# the procedure body
# It will return an empty list or a list of all remaining not name=value
# pair in the argument list
#
proc processInternalArgs {lArgs} {
    debug {======= processInternalArgs $lArgs} 3
    set arglist {}

    # set default errorCode=NONE
    uplevel set errorCode NONE
    # now process all {name value} pair arguments
    foreach arg $lArgs {
	if {[llength $arg] == 2} {
	    debug {uplevel set [lindex $arg 0] \
		    [list [join [lrange $arg 1 end] "="]]} 3
	    uplevel set [lindex $arg 0] \
		    [list [join [lrange $arg 1 end] "="]]
	} else {
	    lappend arglist $arg
	}
    }
    debug {processInternalArgs returns: $arglist} 3
    return $arglist
}

# processTestScriptArgs
#
# This procedure expect all optional arguments to be {name value} pairs
# It will set all variable named to the value given within 
# the procedure body
# It will return an empty list or a list of all remaining not name=value
# pair in the argument list
#
# This is a copy of the procedure "processInternalArgs" without an argument
# however this procedure may become different
#
#
proc processTestScriptArgs {} {
    upvar lArgs lArgs
    set arglist {}

    # set default errorCode=NONE
    uplevel set errorCode NONE
    debug {======= processTestScriptArgs $lArgs} 3
    # now process all {name value} pair arguments
    foreach arg $lArgs {
	if {[llength $arg] == 2} {
	    debug {uplevel set [lindex $arg 0] \
		    [list [join [lrange $arg 1 end] "="]]} 4
	    uplevel set [lindex $arg 0] \
		    [list [join [lrange $arg 1 end] "="]]
	} else {
	    lappend arglist $arg
	}
    }
    debug {        processInternalArgs returns: $arglist} 4
    return $arglist
}

# Command execution command
# This command is like the catch command, however it can do some additional
# testing and in case of an error it will return a error class.
#
proc doCmd {szCmd args} {
    global errorInfo errorCode
    if {! [info exists errorInfo]} {
	set errorInfo "<errorInfo has not been defined>"
    }

    debug {======= doCmd >$szCmd< >$args<} 3
    foreach arg $args {
	set vv [split $arg "="]
	if {[llength $vv] == 2} {
	    debug {   ==>> Expected value: [lindex $vv 0]=[eval list \
		    [lindex $vv 1]]} 5
	    set [lindex $vv 0] [eval list [lindex $vv 1]]
	} elseif {[llength $vv] == 1} {
	    if {! [info exists errorObj]} {
		debug {   ==>> upvar $vv errorObj} 5
		if "! [uplevel info exists $vv]" {
		    debug {   ==>> creating: $vv (uplevel)} 5
		    uplevel [list set $vv {}]
		}
		upvar $vv errorObj
	    }
	}
    }
    if {[catch {uplevel 1 $szCmd} szErrMsg]} {
	debug {======= ErrMsg : \n$szErrMsg\n======= from:\n$szCmd} 5
	set errorObj ""
	if {[string compare $errorCode NONE] == 0} {
	    set errorCode UNDEFINED
	}
	set errorInfoSave $errorInfo
	set errorCodeSave $errorCode
	catch {set errorObj [uplevel infoWhich \{$szErrMsg\}]}
	set errorInfo $errorInfoSave
	set errorCode $errorCodeSave
	debug {   ==>> errorObj: >$errorObj<} 5
	if {[string compare $errorObj ""] == 0} {
	    set errorObj [uplevel \
		    ::BlueGnu::Error #auto \{$errorCode\} \
		    \{$szErrMsg\} \{$errorInfo\}]
	    debug {errorObj: >$errorObj<} 5
	    set errorObj [uplevel infoWhich \{$errorObj\}]
	    debug {errorObj: >$errorObj<} 5
	    debug {Command: [string trim $szCmd]} 5
	    debug {ErrMsg : \n$szErrMsg} 5
	    debug {====================} 5
	    global errorInfo
	    debug {ErrInfo: $errorInfo\n====================} 5
	}
	set bReturn 1
	if {[info exists errorCode]} {
	    debug {        errorCode= $errorCode} 5
	    debug {            Class= [$errorObj info class]} 5
	    catch {debug {       isa BC_RTN= [$errorObj isa BC_RTN]} 5}
	    catch {debug {        isa ERROR= [$errorObj isa Error]} 5}
	    catch {
		if [$errorObj isa BC_RTN] {
		    if {[set i \
			    [lsearch -exact $errorCode \
			    [list [$errorObj SEVERITY] \
			    [$errorObj FACILITY] [$errorObj CODE]]]] >= 0} {
			setup_xfail
			set bReturn 0
		    }
		    fail "Expected errorCode=$errorCode, got:\
			    [$errorObj getShortMsg]\
			    \{[$errorObj SEVERITY] [$errorObj FACILITY]\
			    [$errorObj CODE]\} for >$szCmd<"
		    #verbose { errorCode: [$errorObj errorCode]}
		    #verbose {       why: [$errorObj why]}
		    #verbose {verboseWhy: [$errorObj verboseWhy]} 2
		}
	    }
	    catch {
		if [$errorObj isa Error] {
		    debug {            Error= [$errorObj errorCode]} 5
		    if {[set i \
			    [lsearch -exact $errorCode \
			    [$errorObj errorCode]]] >= 0} {
			setup_xfail
			set bReturn 0
		    }
		    fail "Expected errorCode=$errorCode, got:\
			    [$errorObj errorCode] for >$szCmd<"
		    verbose { errorCode: [$errorObj errorCode]}
		    verbose {       why: [$errorObj why]}
		    verbose {verboseWhy: [$errorObj verboseWhy]} 2
		}
	    }
	}
	return $bReturn
    } else {
	set bReturn 0
	set NOT ""
	if {[info exists errorCode]} {
	    if {[lsearch -exact $errorCode "NONE"] < 0} {
		setup_xfail
		set NOT "not "
		set bReturn 1
	    }
	    pass "errorCode=NONE ${NOT}found in expected set\
		    of errorCodes=\{$errorCode\} for >$szCmd<"
	}
	if {[info exists return]} {
	    debug {Return: >$return<} 3
	    set bResult 0
	    set iFalse 0
	    set iFalseFound 0
	    set iTrue 0
	    set iTrueFound 0
	    foreach lResult $return {
		if {[llength $lResult] == 2} {
		    set bFlag [string toupper [lindex $lResult 0]]
		    set szResult [lindex $lResult 1]
		} else {
		    set bFlag ""
		    set szResult [lindex $lResult 0]
		}
		debug {Checking >$szErrMsg< against $bFlag >$szResult<} 3
		switch $bFlag {
		    0 - NOT - NO - FALSE {
			# no matches allowed
			incr iFalse
			debug {Should not match >$szErrMsg< != >$szResult<} 4
			if {[string compare $szErrMsg $szResult] != 0} {
			    pass "The NOT Expected Result >$szResult<\
				    was not found for >$szCmd<"
			    incr iFalseFound
			} else {
			    fail "The NOT Expected Result >$szResult<\
				    was found for >$szCmd<"
			}
		    }
		    1 - {} - YES - TRUE {
			# only one match allowed
			incr iTrue
			debug {Should match >$szErrMsg< == >$szResult<} 4
			if {[string compare $szErrMsg $szResult] == 0} {
			    pass "Expected Result >$szResult<\
				    found for >$szCmd<"
			    incr iTrueFound
			}
		    }
		    default {
			perror "doCmd result flag: 1, 0, <empty>,\
				NOT, YES, NO, TRUE, FALSE"
		    }
		}
	    }
	    set bResult [expr $iFalse == $iFalseFound]
	    if {$iTrue > 0} {
		set bResult [expr $bResult && ($iTrueFound == 1)]
	    }
	    if {! $bResult} {
		fail "Expected Result(s) >$return<\n     \
			 did not match with: >$szErrMsg< for >$szCmd<"
		set bReturn 1
	    }
	}
	if {[info exists errorObj]} {
	    set errorObj $szErrMsg
	}
    }
    return $bReturn
}


# deleteObjects
#
# This procedure takes multiple arguments each can be a single object
# or a list of objects
# it will delete all these object
# No return value
#
proc deleteObjects {args} {
    debug {======= deleteObjects $args} 3
    foreach arg $args {
	foreach object $arg {
	    debug "        delete object >$object<" 4
    	    delete object $object
	}
    }
    return {}
}

# isObject
# This procedure accepts a fully qualified object name as argument
# and checks if that object exists
proc isObject {object} {
    debug {======= isObject $object} 3
    set tmp [namespace tail $object]
    return [expr [lsearch [namespace eval [namespace qualifier $object] {
	::itcl::find objects
    }
    ] $tmp] >= 0]
}

# checkObject
# This procedure takes an object and a class name is argument
# It checks if the object exists, has a counter part in C++ and
# is of the correct class
#
proc checkObject {object szClassName} {
    debug {======= checkObject $object $szClassName} 3
    if {! [catch {
	set class [uplevel "$object info class"]
	if {[catch {[findObject $object] isa $szClassName} bCl]} {
	    if {[string compare [namespace tail $class] \
		    [namespace tail $szClassName]] == 0} {
		debug {Class [namespace tail $szClassName]\
			match class of object} 4
	    } else {
		error "Miss match"
	    }
	} elseif {! $bCl} {
	    error 1
	}
    } iRet]} {
	return 1
    }

    set obj [findObject $object]
    set class [findClass $szClassName]
    if {[string length $obj] > 0 && [string length $class] > 0} {
	debug {   ==>> object and class passed do exists} 4
	if {[catch {set bISA [$obj isa $class]}]} {
	    debug {Class $szClassName is not inscope to match $object} 4
	    return 0
	}
	if {! $bISA} {
	    debug {$object is not of Class $szClassName} 4
	    return 0
	}
    } else {
	debug {$object and/or $szClassName have not been found!} 4
	return 0
    }
    return 1
}

# findObject
# This procedure take the name of an object, possibly without any qualifier
# and search all namespaces to find the object.
# When a qualifier is specified, it will check if it is complete
# The procedure return the fully qualified name of the object if it exists or
# an empty string otherwise.
#
proc findObject {object {namespace ::}} {
    debug {======= findObject $object $namespace} 3
    set ns [namespace qualifier $object]
    set obj [namespace tail $object]
    set objs [namespace eval $namespace {::itcl::find objects}]
    if {[lsearch $objs $obj] >= 0} {
	regsub "::$" $namespace "" namespace
	return ${namespace}::$obj
    } else {
	set result ""
	foreach cns [namespace children $namespace] {
	    set result [findObject $obj $cns]
	    if {[string length $result] > 0} break
	}
    }
    return $result
}

# findClass
# This procedure take the name of an class, possibly without any qualifier
# and search all namespaces to find the class.
# When a qualifier is specified, it will check if it is complete
# The procedure return the fully qualified name of the Class if it exists or
# an empty string otherwise.
#
proc findClass {class {namespace ::}} {
    debug {======= findClass $class $namespace} 3
    set ns [namespace qualifier $class]
    set obj [namespace tail $class]
    set objs [namespace eval $namespace {::itcl::find classes}]
    if {[lsearch $objs $obj] >= 0} {
	regsub "::$" $namespace "" namespace
	return ${namespace}::$obj
    } else {
	set result ""
	foreach cns [namespace children $namespace] {
	    set result [findClass $obj $cns]
	    if {[string length $result] > 0} break
	}
    }
    return $result
}

# The parseTest command will validate the argument as an existing
# test including testCaseID and arguments.
# It will return a list of all acceptable test script
#
proc parseTest {args} {
    global szCurrentTestDirectory
    debug {======= parseTest $args} 3

    foreach arg $args {
	foreach szTest $arg {
	    regexp {([^[=]+)([[][^]]*[]])?(.*)} $szTest dummy szT szID szA
	    debug {dummy: >$dummy<} 4
	    debug {szT  : >$szT<} 4
	    if {[string length $szID] > 0} {
		#regexp {[[]([^]]+)[]]} $szID dummy szID
	    }
	    debug {szID : >$szID<} 4
	    if {[string length $szA] > 0} {
		#regexp {=(.*)} $szA dummy szA
	    }
	    debug {szA  : >$szA<} 4
	    set szFileName $szT
	    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
		lappend testList [file join $szCurrentTestDirectory $szTest]
	    } 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
			lappend testList ${test}${szID}${szA}
		    } else {
			warning "Test >$test< can't be found"
		    }
		}
	    } else {
		perror "$szFileName is not a test!\
			Does not exists!"
	    }
	}
    }
    if [info exists testList] {
	if [llength $testList] {
	    return $testList
	}
    }
    return [list]
}

# The global available runtest procedure
# this procedure will find the current environment
# and execute the runTest procedure in that environment

proc runtest {args} {
    global objCurrentEnvironment szCurrentTestDirectory
    debug {======= runtest $args} 3
    set elResult [list]

    if {[llength $args] > 0} {
	set Env [lindex $args 0]
	debug {   Checking for environment: >$Env<} 3
	debug {      >[infoWhich $Env]<} 5
	debug {   Current Test Directory: >$szCurrentTestDirectory<} 5
	if {[string compare [infoWhich $Env] ""] == 0} {
	    debug {      not an environment} 4
	    if {[info exist objCurrentEnvironment] && \
		    [string compare \
		    [infoWhich $objCurrentEnvironment] ""] != 0} {
		debug {      Found Current Environment\
			>$objCurrentEnvironment<} 5
		set Env $objCurrentEnvironment
	    } else {
		error "NO default environent"
	    }
	} else {
	    debug {     is an environment} 3
	    set args [lrange $args 1 end]
	}
	set T [lindex $args 0]
	set A [lindex $args 1]
	set I [lindex $args 2]
	foreach t [appendTestCaseID [appendArguments [parseTest $T] $A] $I] {
	    debug {   ==>> $objCurrentEnvironment\
		    runTest $t} 3
	    lappend elResult \
		    [$Env runTest $t]
	}
    } else {
	warning "No tests have been passed to runtest procedure!"
    }
    return $elResult
}

proc appendQueue {args} {
    global objCurrentQueue szCurrentTestDirectory
    debug {======= appendQueue $args} 3

    set iRun 0
    set Queue [lindex $args 0]
    if {[string compare [infoWhich $Queue] ""] == 0} {
	if {[info exist objCurrentQueue]} {
	    set Queue $objCurrentQueue
	} else {
	    error "NO default queue"
	}
    } else {
	set args [lrange $args 1 end]
    }
    set T [lindex $args 0]
    set A [lindex $args 1]
    set I [lindex $args 2]
    foreach t [appendTestCaseID [appendArguments [parseTest $T] $A] $I] {
	debug {   ==>> $Queue append $t} 3
	incr iRun
	$Queue append $t
    }
    if {$iRun == 0} {
	warning "NO argument to appendQueue have been processed"
    }
}

proc prependQueue {args} {
    global objCurrentQueue szCurrentTestDirectory
    debug {======= prependQueue $args} 3

    set iRun 0
    set Queue [lindex $args 0]
    if {[string compare [infoWhich [lindex $args 0]] ""] == 0} {
	if {[info exist objCurrentQueue]} {
	    set Queue $objCurrentQueue
	} else {
	    error "NO default queue"
	}
    } else {
	set args [lrange $args 1 end]
    } 
    set T [lindex $args 0]
    set A [lindex $args 1]
    set I [lindex $args 2]
    foreach t [appendTestCaseID [appendArguments [parseTest $T] $A] $I] {
	incr iRun
	lappend comList $t
    }
    debug {   ==>> $Queue prepend $comList} 3
    eval $Queue prepend $comList

    if {$iRun == 0} {
	warning "NO argument to appendQueu have been processed"
    }
}

proc perror {args} {
    global errorInfo
    global objCurrentTest
    global objCurrentEnvironment

    # save errorInfo
    set errorInfoSave $errorInfo

    if { [llength $args] > 1 } {
	set $::BlueGnu::errcnt [lindex [uplevel set args] 1]
    } else {
	incr ::BlueGnu::errcnt
    }

    while 1 {
	set szMsg [lindex $args 0]

	if {[catch {$objCurrentTest perror $szMsg} \
		szErrMsg]} {
	    if {[info exists objCurrentTest]} {
		debug {No current test: >$szErrMsg<:\
			current test >$objCurrentTest< message:\n    \
			$szMsg} 3
	    } else {
		debug {PERROR: No current test: >$szErrMsg<:\
			current test >DOES NOT EXIST< message:\n    \
			$szMsg} 3
		debug {        info: >>>$errorInfo<<<} 4
	    }
	} else {
	    break
	}
	catch {
	    set szCmd [concat \"$objCurrentEnvironment\" record_test \
		    ERROR \$szMsg]
	}
	if {[catch {eval $szCmd} szErrMsg]} {
	    verbose {No current environment (ERROR): >$szErrMsg<} 3
	} else {
	    break
	}

	::BlueGnu::clone_output "ERROR: $szMsg"
	namespace eval ::BlueGnu {
	    set errno "ERROR: [uplevel set szMsg]"
	}
	break
    }

    # restore errorInfo
    set errorInfo $errorInfoSave
}

proc warning {args} {
    global errorInfo
    global objCurrentTest
    global objCurrentEnvironment

    # save errorInfo
    set errorInfoSave $errorInfo

    if { [llength $args] > 1 } {
	namespace eval ::BlueGnu {
	    set warncnt [lindex [uplevel set args] 1]
	}
    } else {
	namespace eval ::BlueGnu {
	    incr warncnt
	}
    }

    while 1 {
	set szMsg [lindex $args 0]

	if {[catch {$objCurrentTest warning $szMsg} \
		szErrMsg]} {
	    if {[info exists objCurrentTest]} {
		verbose {No current test: >$szErrMsg<:\
			current test >$objCurrentTest< message:\n    \
			$szMsg} 3
	    } else {
		verbose {WARNING: No current test: >$szErrMsg<:\
			current test >DOES NOT EXIST< message:\n    \
			$szMsg} 3
	    }
	} else {
	    break
	}
	catch {
	    set szCmd [concat \"$objCurrentEnvironment\" record_test \
		    WARNING \$szMsg]
	}
	if {[catch {eval $szCmd} szErrMsg]} {
	    verbose {No current environment (WARNING): >$szErrMsg<} 3
	} else {
	    break
	}
    
	set szMsg [lindex $args 0]
	::BlueGnu::clone_output "WARNING: $szMsg"
	namespace eval ::BlueGnu {
	    set errno "WARNING: [uplevel set szMsg]"
	}
	break
    }
    if 0 {
	uplevel #0 {
	    verbose {uplevel #0 to remove errorInfo}
	    if [info exists errorInfo] {
		unset errorInfo
	    }
	}
    }
    # restore errorInfo
    set errorInfo $errorInfoSave
}

proc note {szMsg} {
    global objCurrentTest

    $objCurrentTest note $szMsg
}

proc pass {szMsg} {
    global objCurrentTest

    $objCurrentTest pass $szMsg
}

proc fail {szMsg} {
    global objCurrentTest

    $objCurrentTest fail $szMsg
}

proc unresolved {szMsg} {
    global objCurrentTest

    $objCurrentTest unresolved $szMsg
}

proc untested {szMsg} {
    global objCurrentTest

    $objCurrentTest untested $szMsg
}

proc unsupported {szMsg} {
    global objCurrentTest

    $objCurrentTest unsupported $szMsg
}

proc get_warning_threshold {} {
    return [namespace eval ::BlueGnu {set warning_threshold}]
}

proc set_warning_threshold {threshold} {
    namespace eval ::BlueGnu {
	set warning_threshold [uplevel set threshold]
    }
}

proc setup_xfail {args} {
    namespace eval ::BlueGnu {set xfail_flag 1}
}

proc clear_xfail {args} {
    namespace eval ::BlueGnu {set xfail_flag 0}
}

proc benchmark {benchmarkFunction args} {
    debug {======= benchmark $benchmarkFunction $args}
    global objCurrentTest
    global errorInfo

    if 0 {
	debug {[foreach var [info vars] {
	    verbose {local var: >$var<}}]
	}
	uplevel {
	    debug {[foreach var [info vars] {
		verbose {uplevel local var: >$var<}}]
	    }
	}
	debug {[foreach var [info globals] {
	    verbose {global var: >$var<}}]
	}
    }

    set errorInfo ""
    set szID [$objCurrentTest ID]
    set szTestCaseID [$objCurrentTest testCaseID]
    set benchmarkObject [$objCurrentTest benchmarkObject]
    set benchmarkClassName [$objCurrentTest benchmarkClassName]
    debug {   ==>>      test ID: >$szID<} 3
    debug {        test case ID: >$szTestCaseID<} 3
    debug {   check test object: >$benchmarkObject<} 3
    if {$benchmarkObject == ""} {
	warning "NO Benchmark Class defines for >$benchmarkClassName<"
	set bResult 0
    } else {
	if [catch {
	    set bResult [eval $benchmarkObject benchmark \
		    $benchmarkFunction $args]
	} errMsg] {
	    warning "NO checking has been done for\
		    ${benchmarkClassName}::benchmark $benchmarkFunction $args"
	    debug {[perror "BenchmarkFunction: >$benchmarkFunction<\
		    has not been defined\
		    in class $benchmarkClassName\n### Error Msg: $errMsg"]} 0
	    debug {### Error Info: $errorInfo} 0
	    set bResult 0
	}
    }
    return $bResult
}

proc envPATH {szAction szDir} {
    debug {======= envPATH $szAction $szDir} 3

    global env
    if [file isdirectory $szDir] {
	# remove directory from Path if it exists
	set envPATH $env(PATH)
	while {[regsub :?$szDir:? $envPATH {:} envPATH]} {
	}
	regsub {^:} $envPATH {} envPATH
	regsub {:$} $envPATH {} envPATH
	set env(PATH) $envPATH
	switch $szAction {
	    prefix -
	    prepend {
		set env(PATH) "$szDir:$env(PATH)"
	    }
	    append {
		append env(PATH) ":$szDir"
	    }
	    default {
	    }
	}
    }
}

# replacement for info which commaond
#
proc infoWhich {name {namespace ::}} {
    debug {======= infoWhich $name $namespace} 3
    if [catch {uplevel set infoWhich__name $name} szErrMsg] {
	debug {        error: $szErrMsg}
	return ""
    }
    uplevel {
	debug {         objects: >[::itcl::find objects]<} 4
	debug {       namespace: >[namespace current]<} 4
	infoWhichYYY
    }
    set name [uplevel set infoWhich__name]
    uplevel unset infoWhich__name
    debug {infoWhich return: >$name<} 4
    return $name
}
proc infoWhichXXX {} {
    uplevel {
	set i [lsearch -regexp [::itcl::find objects] "[namespace tail \
		$infoWhich__name]"]
	if {$i < 0} {
	    set infoWhich__name ""
	} else {
	    set infoWhich__name [lindex [::itcl::find objects] $i]
	    if {! [string match ::* $infoWhich__name]} {
		set infoWhich__name [namespace current]::$infoWhich__name
	    }
	    regsub "^::::" $infoWhich__name "::" infoWhich__name
	}
    }
}
proc infoWhichYYY {} {
    uplevel {
	if [catch {infoWhichXXX} szErrMsg] {
	    verbose "infoWhichYYY error Msg: $szErrMsg"
	    set infoWhich__name ""
	}
    }
}

namespace eval ::BlueGnu {
    variable warning_threshold 0

    variable sum_file stdout
    variable all_flag 0

    variable xfail_flag 0
    variable xfail_prms {}
    #
    # Print output to stdout (or stderr) and to log file
    #
    # If the --all flag (-a) option was used then all messages
    # go the the screen.
    # Without this, all messages that start with a keyword are
    # written only to the
    # detail log file.  All messages that go to the screen will
    # also appear in the
    # detail log.  This should only be used by the framework itself using pass,
    # fail, xpass, xfail, warning, perror, note, untested, unresolved, or
    # unsupported procedures.
    #
    proc clone_output {message} {
	variable sum_file
	variable all_flag

	#everything goes in the summary file
	#
	puts $sum_file "$message"

	# Depending on the type of message, the message is send
	# to other resources
	#
	case [lindex [split $message] 0] in {
	    {"FAIL:" "XPASS:" "UNRESOLVED:" "UNSUPPORTED:" "UNTESTED:"} {
		send_user "$message\n"
		send_log "$message\n"
	    }
	    {"PASS:" "XFAIL:"} {
		if $all_flag {
		    send_user "$message\n"
		}
		send_log "$message\n"
	    }
	    "ERROR:" {
		#send_user "$message\n"
		send_error "$message\n"
		send_log "$message\n"
	    }
	    {"WARNING:" "NOTE:"} {
		if $all_flag {
		    send_error "$message\n"
		}
		send_log "$message\n"
	    }
	    "*******" {
		send_user "$message\n"
		#send_log "$message\n"
		#send_error "$message\n"
	    }
	    default {
		send_user "$message\n"
	    }
	}

	# we always return turn the message unchanged
	#
	return "$message"
    }
}

proc createTarget {args} {
    verbose {In: createTarget >$args<} 3
    set szCmd "::BlueGnu::Target #auto "
    set bID 0
    set bEnv 0
    set bQueue 0
    foreach item $args {
	if {[string compare \
		[lindex [split $item "="] 0] szID] == 0} {
	    set bID 1
	}
	if {[string compare \
		[lindex [split $item "="] 0] objEnvironment] == 0} {
	    set bEnv 1
	}
	if {[string compare \
		[lindex [split $item "="] 0] objQueue] == 0} {
	    set bQueue 1
	}
	append szCmd "\{$item\} "
    }
    if {! $bID} {
	append szCmd "szID=Default "
    }
    if {! $bEnv} {
	append szCmd "objEnvironment=[infoWhich \
		[::BlueGnu::Environment #auto]] "
    }
    if {! $bQueue} {
	append szCmd "objQueue=[infoWhich [::BlueGnu::Queue #auto]] "
    }
    verbose {Command: >$szCmd<} 3
    set target [uplevel #0 "eval $szCmd"]
    verbose {Created target: >$target<} 3
    verbose {              >>>[$target <<]<<<} 4
    verbose {              >>>[[infoWhich $target] <<]<<<} 4
    verbose {    == [join [$target <<] "\n    == "]} 3
    return [infoWhich $target]
}

# Initialize all global variables not yet initialized
#
set szCurrentTestDirectory $env(TESTSUITEROOT)

# Remove all temporary variables from the global space
catch {eval unset [info globals __*]}
debug {Global variables available:\
	\n   [join [lsort [info globals]] "\n   "]} 9
debug {Global procedures available:\
	\n   [join [lsort [info procs]] "\n   "]} 9

foreach dir [split $env(TESTSETS) ":"] {
    if {[string compare $dir $PWD] == 0} {
	foreach indexFile [locateFile tclIndex] {
	    set indexDir [file dirname $indexFile]
	    if {[lsearch -exact [split $auto_path] $indexDir] < 0} {
		set auto_path "$indexDir $auto_path"
	    }
	}
	foreach indexFile [locateFile tclIndex lib] {
	    set indexDir [file dirname $indexFile]
	    if {[lsearch -exact [split $auto_path] $indexDir] < 0} {
		set auto_path "$indexDir $auto_path"
	    }
	}
    } else {
	if {[file exists $dir/tclIndex]} {
	    set auto_path "$dir $auto_path"
	}
    }
}
debug {auto_path has been intialize to:\n      [join $auto_path "\n      "]} 3
verbose {TESTSETS: >$env(TESTSETS)<} 3