# tcltest.tcl --

#

#	This file contains support code for the Tcl test suite.  It

#       defines the tcltest namespace and finds and defines the output

#       directory, constraints available, output and error channels,

#	etc. used by Tcl tests.  See the tcltest man page for more

#	details.

#

#       This design was based on the Tcl testing approach designed and

#       initially implemented by Mary Ann May-Pumphrey of Sun

#	Microsystems.

#

# Copyright (c) 1994-1997 Sun Microsystems, Inc.

# Copyright (c) 1998-1999 by Scriptics Corporation.

# Copyright (c) 2000 by Ajuba Solutions

# Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)

# All rights reserved.

#

# RCS: @(#) $Id: tcltest.tcl,v 1.78.2.13 2005/02/24 18:03:36 dgp Exp $

package require Tcl 8.3		;# uses [glob -directory]

namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,

    # and the install directory in the Makefiles.  When the minor version

    # changes (new feature) be sure to update the man page as well.

    variable Version 2.2.8

    # Compatibility support for dumb variables defined in tcltest 1

    # Do not use these.  Call [package provide Tcl] and [info patchlevel]

    # yourself.  You don't need tcltest to wrap it for you.

    variable version [package provide Tcl]

    variable patchLevel [info patchlevel]

##### Export the public tcltest procs; several categories

    #

    # Export the main functional commands that do useful things

    namespace export cleanupTests loadTestedCommands makeDirectory \

	makeFile removeDirectory removeFile runAllTests test

    # Export configuration commands that control the functional commands

    namespace export configure customMatch errorChannel interpreter \

	    outputChannel testConstraint

    # Export commands that are duplication (candidates for deprecation)

    namespace export bytestring		;# dups [encoding convertfrom identity]

    namespace export debug		;#	[configure -debug]

    namespace export errorFile		;#	[configure -errfile]

    namespace export limitConstraints	;#	[configure -limitconstraints]

    namespace export loadFile		;#	[configure -loadfile]

    namespace export loadScript		;#	[configure -load]

    namespace export match		;#	[configure -match]

    namespace export matchFiles		;#	[configure -file]

    namespace export matchDirectories	;#	[configure -relateddir]

    namespace export normalizeMsg	;#	application of [customMatch]

    namespace export normalizePath	;#	[file normalize] (8.4)

    namespace export outputFile		;#	[configure -outfile]

    namespace export preserveCore	;#	[configure -preservecore]

    namespace export singleProcess	;#	[configure -singleproc]

    namespace export skip		;#	[configure -skip]

    namespace export skipFiles		;#	[configure -notfile]

    namespace export skipDirectories	;#	[configure -asidefromdir]

    namespace export temporaryDirectory	;#	[configure -tmpdir]

    namespace export testsDirectory	;#	[configure -testdir]

    namespace export verbose		;#	[configure -verbose]

    namespace export viewFile		;#	binary encoding [read]

    namespace export workingDirectory	;#	[cd] [pwd]

    # Export deprecated commands for tcltest 1 compatibility

    namespace export getMatchingFiles mainThread restoreState saveState \

	    threadReap

    # tcltest::normalizePath --

    #

    #     This procedure resolves any symlinks in the path thus creating

    #     a path without internal redirection. It assumes that the

    #     incoming path is absolute.

    #

    # Arguments

    #     pathVar - name of variable containing path to modify.

    #

    # Results

    #     The path is modified in place.

    #

    # Side Effects:

    #     None.

    #

    proc normalizePath {pathVar} {

	upvar $pathVar path

	set oldpwd [pwd]

	catch {cd $path}

	set path [pwd]

	cd $oldpwd

	return $path

    }

##### Verification commands used to test values of variables and options

    #

    # Verification command that accepts everything

    proc AcceptAll {value} {

	return $value

    }

    # Verification command that accepts valid Tcl lists

    proc AcceptList { list } {

	return [lrange $list 0 end]

    }

    # Verification command that accepts a glob pattern

    proc AcceptPattern { pattern } {

	return [AcceptAll $pattern]

    }

    # Verification command that accepts integers

    proc AcceptInteger { level } {

	return [incr level 0]

    }

    # Verification command that accepts boolean values

    proc AcceptBoolean { boolean } {

	return [expr {$boolean && $boolean}]

    }

    # Verification command that accepts (syntactically) valid Tcl scripts

    proc AcceptScript { script } {

	if {![info complete $script]} {

	    return -code error "invalid Tcl script: $script"

	}

	return $script

    }

    # Verification command that accepts (converts to) absolute pathnames

    proc AcceptAbsolutePath { path } {

	return [file join [pwd] $path]

    }

    # Verification command that accepts existing readable directories

    proc AcceptReadable { path } {

	if {![file readable $path]} {

	    return -code error "\"$path\" is not readable"

	}

	return $path

    }

    proc AcceptDirectory { directory } {

	set directory [AcceptAbsolutePath $directory]

	if {![file exists $directory]} {

	    return -code error "\"$directory\" does not exist"

	}

	if {![file isdir $directory]} {

	    return -code error "\"$directory\" is not a directory"

	}

	return [AcceptReadable $directory]

    }

##### Initialize internal arrays of tcltest, but only if the caller

    # has not already pre-initialized them.  This is done to support

    # compatibility with older tests that directly access internals

    # rather than go through command interfaces.

    #

    proc ArrayDefault {varName value} {

	variable $varName

	if {[array exists $varName]} {

	    return

	}

	if {[info exists $varName]} {

	    # Pre-initialized value is a scalar: destroy it!

	    unset $varName

	}

	array set $varName $value

    }

    # save the original environment so that it can be restored later

    ArrayDefault originalEnv [array get ::env]

    # initialize numTests array to keep track of the number of tests

    # that pass, fail, and are skipped.

    ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]

    # createdNewFiles will store test files as indices and the list of

    # files (that should not have been) left behind by the test files

    # as values.

    ArrayDefault createdNewFiles {}

    # initialize skippedBecause array to keep track of constraints that

    # kept tests from running; a constraint name of "userSpecifiedSkip"

    # means that the test appeared on the list of tests that matched the

    # -skip value given to the flag; "userSpecifiedNonMatch" means that

    # the test didn't match the argument given to the -match flag; both

    # of these constraints are counted only if tcltest::debug is set to

    # true.

    ArrayDefault skippedBecause {}

    # initialize the testConstraints array to keep track of valid

    # predefined constraints (see the explanation for the

    # InitConstraints proc for more details).

    ArrayDefault testConstraints {}

##### Initialize internal variables of tcltest, but only if the caller

    # has not already pre-initialized them.  This is done to support

    # compatibility with older tests that directly access internals

    # rather than go through command interfaces.

    #

    proc Default {varName value {verify AcceptAll}} {

	variable $varName

	if {![info exists $varName]} {

	    variable $varName [$verify $value]

	} else {

	    variable $varName [$verify [set $varName]]

	}

    }

    # Save any arguments that we might want to pass through to other

    # programs.  This is used by the -args flag.

    # FINDUSER

    Default parameters {}

    # Count the number of files tested (0 if runAllTests wasn't called).

    # runAllTests will set testSingleFile to false, so stats will

    # not be printed until runAllTests calls the cleanupTests proc.

    # The currentFailure var stores the boolean value of whether the

    # current test file has had any failures.  The failFiles list

    # stores the names of test files that had failures.

    Default numTestFiles 0 AcceptInteger

    Default testSingleFile true AcceptBoolean

    Default currentFailure false AcceptBoolean

    Default failFiles {} AcceptList

    # Tests should remove all files they create.  The test suite will

    # check the current working dir for files created by the tests.

    # filesMade keeps track of such files created using the makeFile and

    # makeDirectory procedures.  filesExisted stores the names of

    # pre-existing files.

    #

    # Note that $filesExisted lists only those files that exist in

    # the original [temporaryDirectory].

    Default filesMade {} AcceptList

    Default filesExisted {} AcceptList

    proc FillFilesExisted {} {

	variable filesExisted

	# Save the names of files that already exist in the scratch directory.

	foreach file [glob -nocomplain -directory [temporaryDirectory] *] {

	    lappend filesExisted [file tail $file]

	}

	# After successful filling, turn this into a no-op.

	proc FillFilesExisted args {}

    }

    # Kept only for compatibility

    Default constraintsSpecified {} AcceptList

    trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \

		[array names ::tcltest::testConstraints] ;# }

    # tests that use threads need to know which is the main thread

    Default mainThread 1

    variable mainThread

    if {[info commands thread::id] != {}} {

	set mainThread [thread::id]

    } elseif {[info commands testthread] != {}} {

	set mainThread [testthread id]

    }

    # Set workingDirectory to [pwd]. The default output directory for

    # Tcl tests is the working directory.  Whenever this value changes

    # change to that directory.

    variable workingDirectory

    trace variable workingDirectory w \

	    [namespace code {cd $workingDirectory ;#}]

    Default workingDirectory [pwd] AcceptAbsolutePath

    proc workingDirectory { {dir ""} } {

	variable workingDirectory

	if {[llength [info level 0]] == 1} {

	    return $workingDirectory

	}

	set workingDirectory [AcceptAbsolutePath $dir]

    }

    # Set the location of the execuatble

    Default tcltest [info nameofexecutable]

    trace variable tcltest w [namespace code {testConstraint stdio \

	    [eval [ConstraintInitializer stdio]] ;#}]

    # save the platform information so it can be restored later

    Default originalTclPlatform [array get ::tcl_platform]

    # If a core file exists, save its modification time.

    if {[file exists [file join [workingDirectory] core]]} {

	Default coreModTime \

		[file mtime [file join [workingDirectory] core]]

    }

    # stdout and stderr buffers for use when we want to store them

    Default outData {}

    Default errData {}

    # keep track of test level for nested test commands

    variable testLevel 0

    # the variables and procs that existed when saveState was called are

    # stored in a variable of the same name

    Default saveState {}

    # Internationalization support -- used in [SetIso8859_1_Locale] and

    # [RestoreLocale]. Those commands are used in cmdIL.test.

    if {![info exists [namespace current]::isoLocale]} {

	variable isoLocale fr

	switch -- $::tcl_platform(platform) {

	    "unix" {

		# Try some 'known' values for some platforms:

		switch -exact -- $::tcl_platform(os) {

		    "FreeBSD" {

			set isoLocale fr_FR.ISO_8859-1

		    }

		    HP-UX {

			set isoLocale fr_FR.iso88591

		    }

		    Linux -

		    IRIX {

			set isoLocale fr

		    }

		    default {

			# Works on SunOS 4 and Solaris, and maybe

			# others...  Define it to something else on your

			# system if you want to test those.

			set isoLocale iso_8859_1

		    }

		}

	    }

	    "windows" {

		set isoLocale French

	    }

	}

    }

    variable ChannelsWeOpened; array set ChannelsWeOpened {}

    # output goes to stdout by default

    Default outputChannel stdout

    proc outputChannel { {filename ""} } {

	variable outputChannel

	variable ChannelsWeOpened

	# This is very subtle and tricky, so let me try to explain.

	# (Hopefully this longer comment will be clear when I come

	# back in a few months, unlike its predecessor :) )

	# 

	# The [outputChannel] command (and underlying variable) have to

	# be kept in sync with the [configure -outfile] configuration

	# option ( and underlying variable Option(-outfile) ).  This is

	# accomplished with a write trace on Option(-outfile) that will

	# update [outputChannel] whenver a new value is written.  That

	# much is easy.

	#

	# The trick is that in order to maintain compatibility with

	# version 1 of tcltest, we must allow every configuration option

	# to get its inital value from command line arguments.  This is

	# accomplished by setting initial read traces on all the

	# configuration options to parse the command line option the first

	# time they are read.  These traces are cancelled whenever the

	# program itself calls [configure].

	# 

	# OK, then so to support tcltest 1 compatibility, it seems we want

	# to get the return from [outputFile] to trigger the read traces,

	# just in case.

	#

	# BUT!  A little known feature of Tcl variable traces is that 

	# traces are disabled during the handling of other traces.  So,

	# if we trigger read traces on Option(-outfile) and that triggers

	# command line parsing which turns around and sets an initial

	# value for Option(-outfile) -- <whew!> -- the write trace that

	# would keep [outputChannel] in sync with that new initial value

	# would not fire!

	#

	# SO, finally, as a workaround, instead of triggering read traces

	# by invoking [outputFile], we instead trigger the same set of

	# read traces by invoking [debug].  Any command that reads a

	# configuration option would do.  [debug] is just a handy one.

	# The end result is that we support tcltest 1 compatibility and

	# keep outputChannel and -outfile in sync in all cases.

	debug

	if {[llength [info level 0]] == 1} {

	    return $outputChannel

	}

	if {[info exists ChannelsWeOpened($outputChannel)]} {

	    close $outputChannel

	    unset ChannelsWeOpened($outputChannel)

	}

	switch -exact -- $filename {

	    stderr -

	    stdout {

		set outputChannel $filename

	    }

	    default {

		set outputChannel [open $filename a]

		set ChannelsWeOpened($outputChannel) 1

		# If we created the file in [temporaryDirectory], then

		# [cleanupTests] will delete it, unless we claim it was

		# already there.

		set outdir [normalizePath [file dirname \

			[file join [pwd] $filename]]]

		if {[string equal $outdir [temporaryDirectory]]} {

		    variable filesExisted

		    FillFilesExisted

		    set filename [file tail $filename]

		    if {[lsearch -exact $filesExisted $filename] == -1} {

			lappend filesExisted $filename

		    }

		}

	    }

	}

	return $outputChannel

    }

    # errors go to stderr by default

    Default errorChannel stderr

    proc errorChannel { {filename ""} } {

	variable errorChannel

	variable ChannelsWeOpened

	# This is subtle and tricky.  See the comment above in

	# [outputChannel] for a detailed explanation.

	debug

	if {[llength [info level 0]] == 1} {

	    return $errorChannel

	}

	if {[info exists ChannelsWeOpened($errorChannel)]} {

	    close $errorChannel

	    unset ChannelsWeOpened($errorChannel)

	}

	switch -exact -- $filename {

	    stderr -

	    stdout {

		set errorChannel $filename

	    }

	    default {

		set errorChannel [open $filename a]

		set ChannelsWeOpened($errorChannel) 1

		# If we created the file in [temporaryDirectory], then

		# [cleanupTests] will delete it, unless we claim it was

		# already there.

		set outdir [normalizePath [file dirname \

			[file join [pwd] $filename]]]

		if {[string equal $outdir [temporaryDirectory]]} {

		    variable filesExisted

		    FillFilesExisted

		    set filename [file tail $filename]

		    if {[lsearch -exact $filesExisted $filename] == -1} {

			lappend filesExisted $filename

		    }

		}

	    }

	}

	return $errorChannel

    }

##### Set up the configurable options

    #

    # The configurable options of the package

    variable Option; array set Option {}

    # Usage strings for those options

    variable Usage; array set Usage {}

    # Verification commands for those options

    variable Verify; array set Verify {}

    # Initialize the default values of the configurable options that are

    # historically associated with an exported variable.  If that variable

    # is already set, support compatibility by accepting its pre-set value.

    # Use [trace] to establish ongoing connection between the deprecated

    # exported variable and the modern option kept as a true internal var.

    # Also set up usage string and value testing for the option.

    proc Option {option value usage {verify AcceptAll} {varName {}}} {

	variable Option

	variable Verify

	variable Usage

	variable OptionControlledVariables

	set Usage($option) $usage

	set Verify($option) $verify

	if {[catch {$verify $value} msg]} {

	    return -code error $msg

	} else {

	    set Option($option) $msg

	}

	if {[string length $varName]} {

	    variable $varName

	    if {[info exists $varName]} {

		if {[catch {$verify [set $varName]} msg]} {

		    return -code error $msg

		} else {

		    set Option($option) $msg

		}

		unset $varName

	    }

	    namespace eval [namespace current] \

	    	    [list upvar 0 Option($option) $varName]

	    # Workaround for Bug (now Feature Request) 572889.  Grrrr....

	    # Track all the variables tied to options

	    lappend OptionControlledVariables $varName

	    # Later, set auto-configure read traces on all

	    # of them, since a single trace on Option does not work.

	    proc $varName {{value {}}} [subst -nocommands {

		if {[llength [info level 0]] == 2} {

		    Configure $option [set value]

		}

		return [Configure $option]

	    }]

	}

    }

    proc MatchingOption {option} {

	variable Option

	set match [array names Option $option*]

	switch -- [llength $match] {

	    0 {

		set sorted [lsort [array names Option]]

		set values [join [lrange $sorted 0 end-1] ", "]

		append values ", or [lindex $sorted end]"