# 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) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# ========================================================================
# >>>>>>>>>>>>>>>> INCLUDES MODIFICATIONS FOR [incr Tcl] <<<<<<<<<<<<<<<<<
#
#  AUTHOR:  Michael J. McLennan       Phone: (610)712-2842
#           AT&T Bell Laboratories   E-mail: michael.mclennan@att.com
#     RCS:  $Id: defs,v 1.1.1.1 1996/08/21 19:29:49 heyes Exp $
# ========================================================================
#             Copyright (c) 1993-1995  AT&T Bell Laboratories
# ------------------------------------------------------------------------
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

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

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]
    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
}
