defs

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

# This file contains support code for the Tcl test suite.  It is
# normally sourced by the individual files in the test suite before
# they run their tests.  This improved approach to testing was designed
# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
#
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# @(#) defs 1.7 94/12/17 15:53:52
# ------------------------------------------------------------------
# THIS SCRIPT IS NOW DEPRECATED!  It is kept for older Tcl
# installations that don't have the "tcltest" package.
# Instead, use "package require tcltest" in the test suite.
# ------------------------------------------------------------------

package require Iwidgets

if ![info exists VERBOSE] {
    set VERBOSE 0
}
if ![info exists DELAY] {
    set DELAY 0
}
if ![info exists TESTS] {
    set TESTS {}
}

# Some of the tests don't work on some system configurations due to
# configuration quirks, not due to Tk problems;  in order to prevent
# false alarms, these tests are only run in the master development
# directory for Tk.  The presence of a file "doAllTests" in this
# directory is used to indicate that these tests should be run.

set doNonPortableTests [file exists doAllTests]

proc print_verbose {test_name test_description contents_of_test code answer} {
    puts stdout "\n"
    puts stdout "==== $test_name $test_description"
    puts stdout "==== Contents of test case:"
    puts stdout "$contents_of_test"
    if {$code != 0} {
	if {$code == 1} {
	    puts stdout "==== Test generated error:"
	    puts stdout $answer
	} elseif {$code == 2} {
	    puts stdout "==== Test generated return exception;  result was:"
	    puts stdout $answer
	} elseif {$code == 3} {
	    puts stdout "==== Test generated break exception"
	} elseif {$code == 4} {
	    puts stdout "==== Test generated continue exception"
	} else {
	    puts stdout "==== Test generated exception $code;  message was:"
	    puts stdout $answer
	}
    } else {
	puts stdout "==== Result was:"
	puts stdout "$answer"
    }
}

proc test {test_name test_description contents_of_test passing_results} {
    global VERBOSE
    global TESTS
    global DELAY
    if {[string compare $TESTS ""] != 0} then {
	set ok 0
	foreach test $TESTS {
	    if [string match $test $test_name] then {
		set ok 1
		break
	    }
        }
	if !$ok then return
    }
    set code [catch {uplevel $contents_of_test} answer]
    if {$code != 0} {
	print_verbose $test_name $test_description $contents_of_test \
		$code $answer
    } elseif {[string compare $answer $passing_results] == 0} then { 
	if $VERBOSE then {
	    print_verbose $test_name $test_description $contents_of_test \
		    $code $answer
	    puts stdout "++++ $test_name PASSED"
	}
    } else { 
	print_verbose $test_name $test_description $contents_of_test \
		$code $answer 
	puts stdout "---- Result should have been:"
	puts stdout "$passing_results"
	puts stdout "---- $test_name FAILED" 
    }
    after $DELAY
}

#
# Like test, but does reg expr check on the results.
# Useful when the result must follow a pattern but some exact details
# are not necessary, like an internal number appended to a frame, etc.
#
proc test_pattern {test_name test_description contents_of_test passing_results} {
	global VERBOSE
	global TESTS
	if {[string compare $TESTS ""] != 0} then {
		set ok 0
		foreach test $TESTS {
			if [string match $test $test_name] then {
			set ok 1
			break
			}
		}
		if !$ok then return
	}

	set code [catch {uplevel $contents_of_test} answer]

	if {$code != 0} {
		print_verbose $test_name $test_description $contents_of_test \
			$code $answer
	} elseif {[regexp -- [lindex $passing_results 1] [lindex $answer 1]] == 1 } { 
		if $VERBOSE then {
			print_verbose $test_name $test_description $contents_of_test \
				$code $answer
			puts stdout "++++ $test_name PASSED"
		}
	} else { 
		print_verbose $test_name $test_description $contents_of_test \
			$code $answer 
		puts stdout "---- Result should have been:"
		puts stdout "$passing_results"
		puts stdout "**** $test_name FAILED ****" 
	}
}

proc dotests {file args} {
    global TESTS
    set savedTests $TESTS
    set TESTS $args
    source $file
    set TESTS $savedTests
}

# If the main window isn't already mapped (e.g. because the tests are
# being run automatically) , specify a precise size for it so that the
# user won't have to position it manually.

if {![winfo ismapped .]} {
    wm geometry . +0+0
    update
}

# The following code can be used to perform tests involving a second
# process running in the background.

# Locate tktest executable
global argv0
if {0} {
puts "file executable $argv0...[file executable $argv0]"
if { [file executable $argv0] } {
    if { [string index $argv0 0] == "/" } {
	set tktest $argv0
    } else {
	set tktest "[pwd]/$argv0"
    }
} elseif { [file executable ../$argv0] } {
    set tktest "[pwd]/../$argv0"
} else {
    set tktest {}
    puts "Unable to find tktest executable, skipping multiple process tests."
}
} else {set tktest ../tktest}

# Create background process
proc setupbg {{args ""}} {
    global tktest fd bgData
    set fd [open "|$tktest -geometry +0+0 $args" r+]
    puts $fd "puts foo; flush stdout"
    flush $fd
    gets $fd
    fileevent $fd readable bgReady
}

# Send a command to the background process, catching errors and
# flushing I/O channels
proc dobg {command} {
    global fd bgData bgDone
    puts $fd "catch {$command} msg; update; puts \$msg; puts **DONE**; flush stdout"
    flush $fd
    set bgDone 0
    set bgData {}
    tkwait variable bgDone
    set bgData
}

# Data arrived from background process.  Check for special marker
# indicating end of data for this command, and make data available
# to dobg procedure.
proc bgReady {} {
    global fd bgData bgDone
    set x [gets $fd]
    if [eof $fd] {
	fileevent $fd readable {}
	set bgDone 1
    } elseif {$x == "**DONE**"} {
	set bgDone 1
    } else {
	append bgData $x
    }
}

# Exit the background process, and close the pipes
proc cleanupbg {} {
    global fd
    catch {
	puts $fd "exit"
	close $fd
    }
}