tcltest.tcl

这是一个Linux下的集成开发环境

    variable Option
    DebugPuts 3 "entering testConstraint $constraint $value"
    if {[llength [info level 0]] == 2} {
	return $testConstraints($constraint)
    }
    # Check for boolean values
    if {[catch {expr {$value && $value}} msg]} {
	return -code error $msg
    }
    if {[limitConstraints] 
	    && [lsearch -exact $Option(-constraints) $constraint] == -1} {
	set value 0
    }
    set testConstraints($constraint) $value
}

# tcltest::interpreter --
#
#	the interpreter name stored in tcltest::tcltest
#
# Arguments:
#	executable name
#
# Results:
#	content of tcltest::tcltest
#
# Side effects:
#	None.

proc tcltest::interpreter { {interp ""} } {
    variable tcltest
    if {[llength [info level 0]] == 1} {
	return $tcltest
    }
    if {[string equal {} $interp]} {
	set tcltest {}
    } else {
	set tcltest $interp
    }
}

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

# tcltest::AddToSkippedBecause --
#
#	Increments the variable used to track how many tests were
#       skipped because of a particular constraint.
#
# Arguments:
#	constraint     The name of the constraint to be modified
#
# Results:
#	Modifies tcltest::skippedBecause; sets the variable to 1 if
#       didn't previously exist - otherwise, it just increments it.
#
# Side effects:
#	None.

proc tcltest::AddToSkippedBecause { constraint {value 1}} {
    # add the constraint to the list of constraints that kept tests
    # from running
    variable skippedBecause

    if {[info exists skippedBecause($constraint)]} {
	incr skippedBecause($constraint) $value
    } else {
	set skippedBecause($constraint) $value
    }
    return
}

# tcltest::PrintError --
#
#	Prints errors to tcltest::errorChannel and then flushes that
#       channel, making sure that all messages are < 80 characters per
#       line.
#
# Arguments:
#	errorMsg     String containing the error to be printed
#
# Results:
#	None.
#
# Side effects:
#	None.

proc tcltest::PrintError {errorMsg} {
    set InitialMessage "Error:  "
    set InitialMsgLen  [string length $InitialMessage]
    puts -nonewline [errorChannel] $InitialMessage

    # Keep track of where the end of the string is.
    set endingIndex [string length $errorMsg]

    if {$endingIndex < (80 - $InitialMsgLen)} {
	puts [errorChannel] $errorMsg
    } else {
	# Print up to 80 characters on the first line, including the
	# InitialMessage.
	set beginningIndex [string last " " [string range $errorMsg 0 \
		[expr {80 - $InitialMsgLen}]]]
	puts [errorChannel] [string range $errorMsg 0 $beginningIndex]

	while {![string equal end $beginningIndex]} {
	    puts -nonewline [errorChannel] \
		    [string repeat " " $InitialMsgLen]
	    if {($endingIndex - $beginningIndex)
		    < (80 - $InitialMsgLen)} {
		puts [errorChannel] [string trim \
			[string range $errorMsg $beginningIndex end]]
		break
	    } else {
		set newEndingIndex [expr {[string last " " \
			[string range $errorMsg $beginningIndex \
				[expr {$beginningIndex
					+ (80 - $InitialMsgLen)}]
		]] + $beginningIndex}]
		if {($newEndingIndex <= 0)
			|| ($newEndingIndex <= $beginningIndex)} {
		    set newEndingIndex end
		}
		puts [errorChannel] [string trim \
			[string range $errorMsg \
			    $beginningIndex $newEndingIndex]]
		set beginningIndex $newEndingIndex
	    }
	}
    }
    flush [errorChannel]
    return
}

# tcltest::SafeFetch --
#
#	 The following trace procedure makes it so that we can safely
#        refer to non-existent members of the testConstraints array
#        without causing an error.  Instead, reading a non-existent
#        member will return 0. This is necessary because tests are
#        allowed to use constraint "X" without ensuring that
#        testConstraints("X") is defined.
#
# Arguments:
#	n1 - name of the array (testConstraints)
#       n2 - array key value (constraint name)
#       op - operation performed on testConstraints (generally r)
#
# Results:
#	none
#
# Side effects:
#	sets testConstraints($n2) to 0 if it's referenced but never
#       before used

proc tcltest::SafeFetch {n1 n2 op} {
    variable testConstraints
    DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
    if {[string equal {} $n2]} {return}
    if {![info exists testConstraints($n2)]} {
	if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
	    testConstraint $n2 0
	}
    }
}

# tcltest::ConstraintInitializer --
#
#	Get or set a script that when evaluated in the tcltest namespace
#	will return a boolean value with which to initialize the
#	associated constraint.
#
# Arguments:
#	constraint - name of the constraint initialized by the script
#	script - the initializer script
#
# Results
#	boolean value of the constraint - enabled or disabled
#
# Side effects:
#	Constraint is initialized for future reference by [test]
proc tcltest::ConstraintInitializer {constraint {script ""}} {
    variable ConstraintInitializer
    DebugPuts 3 "entering ConstraintInitializer $constraint $script"
    if {[llength [info level 0]] == 2} {
	return $ConstraintInitializer($constraint)
    }
    # Check for boolean values
    if {![info complete $script]} {
	return -code error "ConstraintInitializer must be complete script"
    }
    set ConstraintInitializer($constraint) $script
}

# tcltest::InitConstraints --
#
# Call all registered constraint initializers to force initialization
# of all known constraints.
# See the tcltest man page for the list of built-in constraints defined
# in this procedure.
#
# Arguments:
#	none
#
# Results:
#	The testConstraints array is reset to have an index for each
#	built-in test constraint.
#
# Side Effects:
#       None.
#

proc tcltest::InitConstraints {} {
    variable ConstraintInitializer
    initConstraintsHook
    foreach constraint [array names ConstraintInitializer] {
	testConstraint $constraint
    }
}

proc tcltest::DefineConstraintInitializers {} {
    ConstraintInitializer singleTestInterp {singleProcess}

    # All the 'pc' constraints are here for backward compatibility and
    # are not documented.  They have been replaced with equivalent 'win'
    # constraints.

    ConstraintInitializer unixOnly \
	    {string equal $::tcl_platform(platform) unix}
    ConstraintInitializer macOnly \
	    {string equal $::tcl_platform(platform) macintosh}
    ConstraintInitializer pcOnly \
	    {string equal $::tcl_platform(platform) windows}
    ConstraintInitializer winOnly \
	    {string equal $::tcl_platform(platform) windows}

    ConstraintInitializer unix {testConstraint unixOnly}
    ConstraintInitializer mac {testConstraint macOnly}
    ConstraintInitializer pc {testConstraint pcOnly}
    ConstraintInitializer win {testConstraint winOnly}

    ConstraintInitializer unixOrPc \
	    {expr {[testConstraint unix] || [testConstraint pc]}}
    ConstraintInitializer macOrPc \
	    {expr {[testConstraint mac] || [testConstraint pc]}}
    ConstraintInitializer unixOrWin \
	    {expr {[testConstraint unix] || [testConstraint win]}}
    ConstraintInitializer macOrWin \
	    {expr {[testConstraint mac] || [testConstraint win]}}
    ConstraintInitializer macOrUnix \
	    {expr {[testConstraint mac] || [testConstraint unix]}}

    ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
    ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
    ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}

    # The following Constraints switches are used to mark tests that
    # should work, but have been temporarily disabled on certain
    # platforms because they don't and we haven't gotten around to
    # fixing the underlying problem.

    ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
    ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
    ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
    ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}

    # The following Constraints switches are used to mark tests that
    # crash on certain platforms, so that they can be reactivated again
    # when the underlying problem is fixed.

    ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
    ConstraintInitializer winCrash {expr {![testConstraint win]}}
    ConstraintInitializer macCrash {expr {![testConstraint mac]}}
    ConstraintInitializer unixCrash {expr {![testConstraint unix]}}

    # Skip empty tests

    ConstraintInitializer emptyTest {format 0}

    # By default, tests that expose known bugs are skipped.

    ConstraintInitializer knownBug {format 0}

    # By default, non-portable tests are skipped.

    ConstraintInitializer nonPortable {format 0}

    # Some tests require user interaction.

    ConstraintInitializer userInteraction {format 0}

    # Some tests must be skipped if the interpreter is not in
    # interactive mode

    ConstraintInitializer interactive \
	    {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}

    # Some tests can only be run if the installation came from a CD
    # image instead of a web image.  Some tests must be skipped if you
    # are running as root on Unix.  Other tests can only be run if you
    # are running as root on Unix.

    ConstraintInitializer root {expr \
	    {[string equal unix $::tcl_platform(platform)]
	    && ([string equal root $::tcl_platform(user)]
		|| [string equal "" $::tcl_platform(user)])}}
    ConstraintInitializer notRoot {expr {![testConstraint root]}}

    # Set nonBlockFiles constraint: 1 means this platform supports
    # setting files into nonblocking mode.

    ConstraintInitializer nonBlockFiles {
	    set code [expr {[catch {set f [open defs r]}] 
		    || [catch {fconfigure $f -blocking off}]}]
	    catch {close $f}
	    set code
    }

    # Set asyncPipeClose constraint: 1 means this platform supports
    # async flush and async close on a pipe.
    #
    # Test for SCO Unix - cannot run async flushing tests because a
    # potential problem with select is apparently interfering.
    # (Mark Diekhans).

    ConstraintInitializer asyncPipeClose {expr {
	    !([string equal unix $::tcl_platform(platform)] 
	    && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}

    # Test to see if we have a broken version of sprintf with respect
    # to the "e" format of floating-point numbers.

    ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}

    # Test to see if execed commands such as cat, echo, rm and so forth
    # are present on this machine.

    ConstraintInitializer unixExecs {
	set code 1
        if {[string equal macintosh $::tcl_platform(platform)]} {
	    set code 0
        }
        if {[string equal windows $::tcl_platform(platform)]} {
	    if {[catch {
	        set file _tcl_test_remove_me.txt
	        makeFile {hello} $file
	    }]} {
	        set code 0
	    } elseif {
	        [catch {exec cat $file}] ||
	        [catch {exec echo hello}] ||
	        [catch {exec sh -c echo hello}] ||
	        [catch {exec wc $file}] ||
	        [catch {exec sleep 1}] ||
	        [catch {exec echo abc > $file}] ||
	        [catch {exec chmod 644 $file}] ||
	        [catch {exec rm $file}] ||
	        [llength [auto_execok mkdir]] == 0 ||
	        [llength [auto_execok fgrep]] == 0 ||
	        [llength [auto_execok grep]] == 0 ||
	        [llength [auto_execok ps]] == 0
	    } {
	        set code 0
	    }
	    removeFile $file
        }
	set code
    }

    ConstraintInitializer stdio {
	set code 0
	if {![catch {set f [open "|[list [interpreter]]" w]}]} {
	    if {![catch {puts $f exit}]} {
		if {![catch {close $f}]} {
		    set code 1
		}
	    }
	}
	set code
    }

    # Deliberately call socket with the wrong number of arguments.  The
    # error message you get will indicate whether sockets are available
    # on this system.

    ConstraintInitializer socket {
	catch {socket} msg
	string compare $msg "sockets are not available on this system"
    }

    # Check for internationalization
    ConstraintInitializer hasIsoLocale {
	if {[llength [info commands testlocale]] == 0} {
	    set code 0
	} else {
	    set code [string length [SetIso8859_1_Locale]]
	    RestoreLocale
	}
	set code
    }

}
#####################################################################

# Usage and command line arguments processing.

# tcltest::PrintUsageInfo
#
#	Prints out the usage information for package tcltest.  This can
#	be customized with the redefinition of [PrintUsageInfoHook].
#
# Arguments:
#	none
#
# Results:
#       none
#
# Side Effects:
#       none
proc tcltest::PrintUsageInfo {} {
    puts [Usage]
    PrintUsageInfoHook
}

proc tcltest::Usage { {option ""} } {
    variable Usage
    variable Verify
    if {[llength [info level 0]] == 1} {