#
# testlib.tcl --
#
# Test support routines.  Some of these are based on routines provided with
# standard Tcl.
#------------------------------------------------------------------------------
# Set the global variable or environment variable TEST_ERROR_INFO to display
# errorInfo when a test fails.
#------------------------------------------------------------------------------
# Copyright (c) 1997-1998 Mark Diekhans
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#------------------------------------------------------------------------------
# Copyright 1992-1997 Karl Lehenbauer and Mark Diekhans.
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appear in all copies.  Karl Lehenbauer and
# Mark Diekhans make no representations about the suitability of this
# software for any purpose.  It is provided "as is" without express or
# implied warranty.
#------------------------------------------------------------------------------
# $Id: testlib.tcl,v 1.4 1998/01/07 01:56:11 markd Exp $
#------------------------------------------------------------------------------
#

global TCL_PROGRAM env TEST_ERROR_INFO tcl_platform
global TEST_VERBOSE

if [info exists env(TEST_ERROR_INFO)] {
    set TEST_ERROR_INFO 1
}

if [info exists env(TEST_VERBOSE)] {
    set TEST_VERBOSE 1
}

#
# Convert a Tcl result code to a string.
#
proc TestResultCode code {
    switch -- $code {
        0 {return TCL_OK}
        1 {return TCL_ERROR}
        2 {return TCL_RETURN}
        3 {return TCL_BREAK}
        4 {return TCL_CONTINUE}
        default {return "***Unknown error code $code***"}
    }
}

#
# Output a test error.
#
proc OutTestError {test_name test_description contents_of_test
                   passing_int_result passing_result int_result result} {
    global TEST_ERROR_INFO errorInfo errorCode

    puts stderr "==== $test_name $test_description"
    puts stderr "==== Contents of test case:"
    puts stderr "$contents_of_test"
    puts stderr "==== Result was: [TestResultCode $int_result]"
    puts stderr "$result"
    puts stderr "---- Result should have been: [TestResultCode $passing_int_result]"
    puts stderr "$passing_result"
    puts stderr "---- $test_name FAILED" 
    if {[info exists TEST_ERROR_INFO] && [info exists errorInfo]} {
        puts stderr $errorCode
        puts stderr $errorInfo
        puts stderr "---------------------------------------------------"
    }
}

#
# Routine to execute tests and compare to expected results.
#
proc Test {test_name test_description contents_of_test passing_int_result
           passing_result} {
    global TEST_VERBOSE errorInfo errorCode


    if [info exists TEST_VERBOSE] {
        puts "$test_name $test_description"
    }
    # Clear errorInfo/Code so that TEST_ERROR_INFO doesn't print anything
    # if the test failed but never got an error.
    set errorInfo {}
    set errorCode {}
    set int_result [catch {uplevel $contents_of_test} result]

    if {($int_result != $passing_int_result) ||
        ([string compare $result $passing_result] != 0)} {
        OutTestError $test_name $test_description $contents_of_test \
                     $passing_int_result $passing_result $int_result $result
    }
}

#
# Compare result against case-insensitive regular expression.
#

proc TestReg {test_name test_description contents_of_test passing_int_result
              passing_result} {
    set int_result [catch {uplevel $contents_of_test} result]

    if {($int_result != $passing_int_result) ||
        ![regexp -nocase $passing_result $result]} {
        OutTestError $test_name $test_description $contents_of_test \
                     $passing_int_result $passing_result $int_result $result
    }
}

