# -*- tcl -*-
# This file contains support code for the BLOB 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 (aku@kisters.de)
#
# 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.3 1995/12/16 23:32:50 aku Exp $

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

# 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} {
    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]
#
#    memory active $test_name
#
    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" 
    }
}

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


# -- attention procs --

proc attention-a {} {
    puts {-- ATTENTION --
    Due to the inportability of binary data these tests
    may fail on some machines although the extension was
    compiled successfully and correctly.  The tests will
    account for endianess in prediction of tests-results,
    but not different type sizes. Assumed are:

	char   = 1 byte
	short  = 2 byte
	int    = 4 byte
	long   = 4 byte
	float  = 4 byte
	double = 8 byte

    ----------------------------------------------------
}
rename attention-a {}
}


proc attention-b {} {
    puts {-- ATTENTION again --
    Testing float, double now. The results depend
    completely upon processor architecture.
    Tested for Linux/486 only!
}
rename attention-b {}
}