Tcl Source Code

# defs.tcl --
#
#	This file contains support code for the Tcl/Tk test suite.It is
#	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) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: defs.tcl,v 1.1.2.6 1999/03/24 23:53:44 hershey Exp $

# Initialize wish shell
if {[info exists tk_version]} {
    tk appname tktest
    wm title . tktest
} else {
    # Ensure that we have a minimal auto_path so we don't pick up extra junk.

    # check the current working dir for files created by the tests.
    # ::tcltest::filesMade keeps track of such files created using the
    # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
    # ::tcltest::filesExisted stores the names of pre-existing files.

    variable filesMade {}
    variable filesExisted {}

    # ::tcltest::numTests will store test files as indices and the list
    # of files (that should not have been) left behind by the test files.
    array set ::tcltest::createdNewFiles {}

    # initialize ::tcltest::numTests array to keep track fo the number of
    # tests that pass, fial, and are skipped.
    array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]

    # initialize ::tcltest::skippedBecause array to keep track of
    # constraints that kept tests from running

    if {[catch {array set flag $flagArray}]} {
	puts stderr "Error:  odd number of command line args specified:"
	puts stderr "        $argv"
	exit
    }
    
    # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
    # Note that -verbose cannot be abbreviated to -v in wish because it
    # conflicts with the wish option -visual.
    foreach arg {-verbose -match -skip -constraints} {
	set abbrev [string range $arg 0 1]
	if {([info exists flag($abbrev)]) && \
		([lsearch -exact $flagArray $arg] < \
		[lsearch -exact $flagArray $abbrev])} {
	    set flag($arg) $flag($abbrev)
	}

# since the tests were invoked.
#
# Print the number tests (total, passed, failed, and skipped) since the
# tests were invoked.
#

proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
    set tail [file tail [info script]]

    # Remove files and directories created by the :tcltest::makeFile and
    # ::tcltest::makeDirectory procedures.
    # Record the names of files in ::tcltest::workingDir that were not
    # pre-existing, and associate them with the test file that created them.
    if {!$calledFromAllFile} {

	foreach file $::tcltest::filesMade {
	    if {[file exists $file]} {
		#catch {file delete -force $file}
	    }
	}
	set currentFiles {}
	foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
	    lappend currentFiles [file tail $file]
	}
	set newFiles {}
	foreach file $currentFiles {
	    if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
		lappend newFiles $file
	    }
	}
	set ::tcltest::filesExisted $currentFiles
	if {[llength $newFiles] > 0} {
	    set ::tcltest::createdNewFiles($tail) $newFiles
	}
    }

    if {$calledFromAllFile || $::tcltest::testSingleFile} {
	# print stats
	puts -nonewline stdout "$tail:"
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)"
	}
	puts stdout ""

	    foreach constraint [lsort [array names ::tcltest::skippedBecause]] {
		puts stdout \
			"\t$::tcltest::skippedBecause($constraint)\t$constraint"
		unset ::tcltest::skippedBecause($constraint)
	    }
	}

	# report the names of test files in ::tcltest::createdNewFiles, and

	# reset the array to be empty.

	set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
	if {[llength $testFilesThatTurded] > 0} {

	    puts stdout "Warning: test files left files behind:"
	    foreach testFile $testFilesThatTurded {
		puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
		unset ::tcltest::createdNewFiles($testFile)

	    }



	}

	# reset filesMade, filesExisted, and numTests
	set ::tcltest::filesMade {}

	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    set ::tcltest::numTests($index) 0
	}

	# exit only if running Tk in non-interactive mode
	global tk_version tcl_interactive
	if {[info exists tk_version] && !$tcl_interactive} {

    # process running in the background.
    
    # Locate the tktest executable

    set ::tcltest::tktest [info nameofexecutable]
    if {$::tcltest::tktest == "{}"} {
	set ::tcltest::tktest {}
	puts stdout \
		"Unable to find tktest executable, skipping multiple process tests."
    }

    # Create background process
    
    proc ::tcltest::setupbg args {
	if {$::tcltest::tktest == ""} {
	    error "you're not running tktest so setupbg should not have been called"