# -*- tcl -*-
# This file contains support code for the MEMCHAN 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) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# Modified      1995 Andreas Kupries (a.kupries@westend.com)
# Modified      1997 Andreas Kupries (a.kupries@westend.com)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# CVS: $Id: defs,v 1.1 1999/05/11 18:08:07 aku Exp $


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

if ![info exists DLP] {
    set DLP 0
}




# If tests are being run as root, issue a warning message and set a
# variable to prevent some tests from running at all.

set user {}
catch {set user [exec whoami]}
if {$user == "root"} {
    puts stdout "Warning: you're executing as root.  I'll have to"
    puts stdout "skip some of the tests, since they'll fail as root."
}

# Some of the tests don't work on some system configurations due to
# differences in word length, file system configuration, etc.  In order
# to prevent false alarms, these tests are generally only run in the
# master development directory for Tcl.  The presence of a file
# "doAllTests" in this directory is used to indicate that the non-portable
# 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} {

#error "REREAD failure"

    global VERBOSE
    global TESTS
    global DLP

    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
    }

    if {$DLP} {
	dlp session log "$test_name $test_description"
    }

    set code [catch {uplevel $contents_of_test} answer]
#
#    memory active $test_name
#
    if {$code != 0} {
	print_verbose $test_name $test_description $contents_of_test \
		$code $answer

	if {$DLP} {
	    dlp session log " ERROR\n"
	}
    } 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"
	}

	if {$DLP} {
	    dlp session log "\n"
	}
    } 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" 

	if {$DLP} {
	    dlp session log " FAILED\n"
	}
    }
}

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