tcltest.tcl

linux 下的源代码分析阅读器 red hat公司新版

	set msg "Usage: [file tail [info nameofexecutable]] script "
	append msg "?-help? ?flag value? ... \n"
	append msg "Available flags (and valid input values) are:"

	set max 0
	set allOpts [concat -help [Configure]]
	foreach opt $allOpts {
	    set foo [Usage $opt]
	    foreach [list x type($opt) usage($opt)] $foo break
	    set line($opt) "  $opt $type($opt)  "
	    set length($opt) [string length $line($opt)]
	    if {$length($opt) > $max} {set max $length($opt)}
	}
	set rest [expr {72 - $max}]
	foreach opt $allOpts {
	    append msg \n$line($opt)
	    append msg [string repeat " " [expr {$max - $length($opt)}]]
	    set u [string trim $usage($opt)]
	    catch {append u "  (default: \[[Configure $opt]])"}
	    regsub -all {\s*\n\s*} $u " " u
	    while {[string length $u] > $rest} {
		set break [string wordstart $u $rest]
		if {$break == 0} {
		    set break [string wordend $u 0]
		}
		append msg [string range $u 0 [expr {$break - 1}]]
		set u [string trim [string range $u $break end]]
		append msg \n[string repeat " " $max]
	    }
	    append msg $u
	}
	return $msg\n
    } elseif {[string equal -help $option]} {
	return [list -help "" "Display this usage information."]
    } else {
	set type [lindex [info args $Verify($option)] 0]
	return [list $option $type $Usage($option)]
    }
}

# tcltest::ProcessFlags --
#
#	process command line arguments supplied in the flagArray - this
#	is called by processCmdLineArgs.  Modifies tcltest variables
#	according to the content of the flagArray.
#
# Arguments:
#	flagArray - array containing name/value pairs of flags
#
# Results:
#	sets tcltest variables according to their values as defined by
#       flagArray
#
# Side effects:
#	None.

proc tcltest::ProcessFlags {flagArray} {
    # Process -help first
    if {[lsearch -exact $flagArray {-help}] != -1} {
	PrintUsageInfo
	exit 1
    }

    if {[llength $flagArray] == 0} {
	RemoveAutoConfigureTraces
    } else {
	set args $flagArray
	while {[llength $args] && [catch {eval configure $args} msg]} {

	    # Something went wrong parsing $args for tcltest options
	    # Check whether the problem is "unknown option"
	    if {[regexp {^unknown option (\S+):} $msg -> option]} {
		# Could be this is an option the Hook knows about
		set moreOptions [processCmdLineArgsAddFlagsHook]
		if {[lsearch -exact $moreOptions $option] == -1} {
		    # Nope.  Report the error, including additional options,
		    # but keep going
		    if {[llength $moreOptions]} {
			append msg ", "
			append msg [join [lrange $moreOptions 0 end -1] ", "]
			append msg "or [lindex $moreOptions end]"
		    }
		    Warn $msg
		}
	    } else {
		# error is something other than "unknown option"
		# notify user of the error; and exit
		puts [errorChannel] $msg
		exit 1
	    }

	    # To recover, find that unknown option and remove up to it.
	    # then retry
	    while {![string equal [lindex $args 0] $option]} {
		set args [lrange $args 2 end]
	    }
	    set args [lrange $args 2 end]
	}
    }

    # Call the hook
    array set flag $flagArray
    processCmdLineArgsHook [array get flag]
    return
}

# tcltest::ProcessCmdLineArgs --
#
#       This procedure must be run after constraint initialization is
#	set up (by [DefineConstraintInitializers]) because some constraints
#	can be overridden.
#
#       Perform configuration according to the command-line options.
#
# Arguments:
#	none
#
# Results:
#	Sets the above-named variables in the tcltest namespace.
#
# Side Effects:
#       None.
#

proc tcltest::ProcessCmdLineArgs {} {
    variable originalEnv
    variable testConstraints

    # The "argv" var doesn't exist in some cases, so use {}.
    if {![info exists ::argv]} {
	ProcessFlags {}
    } else {
	ProcessFlags $::argv
    }

    # Spit out everything you know if we're at a debug level 2 or
    # greater
    DebugPuts 2 "Flags passed into tcltest:"
    if {[info exists ::env(TCLTEST_OPTIONS)]} {
	DebugPuts 2 \
		"    ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
    }
    if {[info exists argv]} {
	DebugPuts 2 "    argv: $argv"
    }
    DebugPuts    2 "tcltest::debug              = [debug]"
    DebugPuts    2 "tcltest::testsDirectory     = [testsDirectory]"
    DebugPuts    2 "tcltest::workingDirectory   = [workingDirectory]"
    DebugPuts    2 "tcltest::temporaryDirectory = [temporaryDirectory]"
    DebugPuts    2 "tcltest::outputChannel      = [outputChannel]"
    DebugPuts    2 "tcltest::errorChannel       = [errorChannel]"
    DebugPuts    2 "Original environment (tcltest::originalEnv):"
    DebugPArray  2 originalEnv
    DebugPuts    2 "Constraints:"
    DebugPArray  2 testConstraints
}

#####################################################################

# Code to run the tests goes here.

# tcltest::TestPuts --
#
#	Used to redefine puts in test environment.  Stores whatever goes
#	out on stdout in tcltest::outData and stderr in errData before
#	sending it on to the regular puts.
#
# Arguments:
#	same as standard puts
#
# Results:
#	none
#
# Side effects:
#       Intercepts puts; data that would otherwise go to stdout, stderr,
#	or file channels specified in outputChannel and errorChannel
#	does not get sent to the normal puts function.
namespace eval tcltest::Replace {
    namespace export puts
}
proc tcltest::Replace::puts {args} {
    variable [namespace parent]::outData
    variable [namespace parent]::errData
    switch [llength $args] {
	1 {
	    # Only the string to be printed is specified
	    append outData [lindex $args 0]\n
	    return
	    # return [Puts [lindex $args 0]]
	}
	2 {
	    # Either -nonewline or channelId has been specified
	    if {[string equal -nonewline [lindex $args 0]]} {
		append outData [lindex $args end]
		return
		# return [Puts -nonewline [lindex $args end]]
	    } else {
		set channel [lindex $args 0]
	    }
	}
	3 {
	    if {[string equal -nonewline [lindex $args 0]]} {
		# Both -nonewline and channelId are specified, unless
		# it's an error.  -nonewline is supposed to be argv[0].
		set channel [lindex $args 1]
	    }
	}
    }

    if {[info exists channel]} {
	if {[string equal $channel [[namespace parent]::outputChannel]]
		|| [string equal $channel stdout]} {
	    append outData [lindex $args end]\n
	    return
	} elseif {[string equal $channel [[namespace parent]::errorChannel]]
		|| [string equal $channel stderr]} {
	    append errData [lindex $args end]\n
	    return
	}
    }

    # If we haven't returned by now, we don't know how to handle the
    # input.  Let puts handle it.
    return [eval Puts $args]
}

# tcltest::Eval --
#
#	Evaluate the script in the test environment.  If ignoreOutput is
#       false, store data sent to stderr and stdout in outData and
#       errData.  Otherwise, ignore this output altogether.
#
# Arguments:
#	script             Script to evaluate
#       ?ignoreOutput?     Indicates whether or not to ignore output
#			   sent to stdout & stderr
#
# Results:
#	result from running the script
#
# Side effects:
#	Empties the contents of outData and errData before running a
#	test if ignoreOutput is set to 0.

proc tcltest::Eval {script {ignoreOutput 1}} {
    variable outData
    variable errData
    DebugPuts 3 "[lindex [info level 0] 0] called"
    if {!$ignoreOutput} {
	set outData {}
	set errData {}
	set callerHasPuts [llength [uplevel 1 {
		::info commands [::namespace current]::puts
	}]]
	if {$callerHasPuts} {
	    uplevel 1 [list ::rename puts [namespace current]::Replace::Puts]
	} else {
	    interp alias {} [namespace current]::Replace::Puts {} ::puts
	}
	uplevel 1 [list ::namespace import [namespace origin Replace::puts]]
	namespace import Replace::puts
    }
    set result [uplevel 1 $script]
    if {!$ignoreOutput} {
	namespace forget puts
	uplevel 1 ::namespace forget puts
	if {$callerHasPuts} {
	    uplevel 1 [list ::rename [namespace current]::Replace::Puts puts]
	} else {
	    interp alias {} [namespace current]::Replace::Puts {}
	}
    }
    return $result
}

# tcltest::CompareStrings --
#
#	compares the expected answer to the actual answer, depending on
#	the mode provided.  Mode determines whether a regexp, exact,
#	glob or custom comparison is done.
#
# Arguments:
#	actual - string containing the actual result
#       expected - pattern to be matched against
#       mode - type of comparison to be done
#
# Results:
#	result of the match
#
# Side effects:
#	None.

proc tcltest::CompareStrings {actual expected mode} {
    variable CustomMatch
    if {![info exists CustomMatch($mode)]} {
        return -code error "No matching command registered for `-match $mode'"
    }
    set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
    if {[catch {expr {$match && $match}} result]} {
	return -code error "Invalid result from `-match $mode' command: $result"
    }
    return $match
}

# tcltest::customMatch --
#
#	registers a command to be called when a particular type of
#	matching is required.
#
# Arguments:
#	nickname - Keyword for the type of matching
#	cmd - Incomplete command that implements that type of matching
#		when completed with expected string and actual string
#		and then evaluated.
#
# Results:
#	None.
#
# Side effects:
#	Sets the variable tcltest::CustomMatch

proc tcltest::customMatch {mode script} {
    variable CustomMatch
    if {![info complete $script]} {
	return -code error \
		"invalid customMatch script; can't evaluate after completion"
    }
    set CustomMatch($mode) $script
}

# tcltest::SubstArguments list
#
# This helper function takes in a list of words, then perform a
# substitution on the list as though each word in the list is a separate
# argument to the Tcl function.  For example, if this function is
# invoked as:
#
#      SubstArguments {$a {$a}}
#
# Then it is as though the function is invoked as:
#
#      SubstArguments $a {$a}
#
# This code is adapted from Paul Duffin's function "SplitIntoWords".
# The original function can be found  on:
#
#      http://purl.org/thecliff/tcl/wiki/858.html
#
# Results:
#     a list containing the result of the substitution
#
# Exceptions:
#     An error may occur if the list containing unbalanced quote or
#     unknown variable.
#
# Side Effects:
#     None.
#

proc tcltest::SubstArguments {argList} {

    # We need to split the argList up into tokens but cannot use list
    # operations as they throw away some significant quoting, and
    # [split] ignores braces as it should.  Therefore what we do is
    # gradually build up a string out of whitespace seperated strings.
    # We cannot use [split] to split the argList into whitespace
    # separated strings as it throws away the whitespace which maybe
    # important so we have to do it all by hand.

    set result {}
    set token ""

    while {[string length $argList]} {
        # Look for the next word containing a quote: " { }
        if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
		$argList all]} {
            # Get the text leading up to this word, but not including
	    # this word, from the argList.
            set text [string range $argList 0 \
		    [expr {[lindex $all 0] - 1}]]
            # Get the word with the quote
            set word [string range $argList \
                    [lindex $all 0] [lindex $all 1]]

            # Remove all text up to and including the word from the
            # argList.
            set argList [string range $argList \
                    [expr {[lindex $all 1] + 1}] end]
        } else {
            # Take everything up to the end of the argList.
            set text $argList
            set word {}
            set argList {}
        }

        if {$token != {}} {
            # If we saw a word with quote before, then there is a
            # multi-word token starting with that word.  In this case,
            # add the text and the current word to this token.
            append token $text $word
        } else {
            # Add the text to the result.  There is no need to parse
            # the text because it couldn't be a part of any multi-word
            # token.  Then start a new multi-word token with the word
            # because we need to pass this token to the Tcl parser to
            # check for balancing quotes
            append result $text
            set token $word
        }

        if { [catch {llength $token} length] == 0 && $length == 1} {
            # The token is a valid list so add it to the result.
            # lappend result [string trim $token]
            append result \{$token\}
            set token {}
        }
    }

    # If the last token has not been added to the list then there
    # is a problem.
    if { [string length $token] } {
        error "incomplete token \"$token\""
    }

    return $result
}