1#
2# Old test suite for [incr Tcl] v1.5
3# ----------------------------------------------------------------------
4#   AUTHOR:  Michael J. McLennan
5#            Bell Labs Innovations for Lucent Technologies
6#            mmclennan@lucent.com
7#            http://www.tcltk.com/itcl
8#
9#      RCS:  $Id: testlib.tcl,v 1.1 1998/07/27 18:41:26 stanton Exp $
10# ----------------------------------------------------------------------
11#            Copyright (c) 1993-1998  Lucent Technologies, Inc.
12# ======================================================================
13# See the file "license.terms" for information on usage and
14# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15
16# ----------------------------------------------------------------------
17#  USAGE:  test <test-desc> <test-cmd> <check>
18#
19#  Executes the given test, the evaluates the <check> condition to
20#  see if the test passed.  The result from the <test-cmd> is kept
21#  in the variable $result.  If this condition evaluates non-zero,
22#  the test has passed.  Otherwise, the test has failed.  A variety
23#  if checking routines (test_cmp_*) are provided below to make
24#  the check condition easier to write.
25# ----------------------------------------------------------------------
26proc test {desc cmd check} {
27    set result [uplevel $cmd]
28
29    if {![expr $check]} {
30		puts stdout "-------------------------------------------------------"
31		puts stdout ">>>> FAILED TEST <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
32		puts stdout "-------------------------------------------------------"
33		set lines [split $desc "\n"]
34		foreach i $lines {
35    		puts stdout $i
36		}
37		puts stdout "======================================================="
38		set lines [split $cmd "\n"]
39		set label TEST
40		foreach i $lines {
41    		puts stdout "   $label | $i"
42			set label "    "
43		}
44		puts stdout "-------------------------------------------------------"
45		set lines [split $check "\n"]
46		set label CHECK
47		foreach i $lines {
48			if {$i != ""} {
49    			puts stdout "  $label | $i"
50				set label "     "
51			}
52		}
53		puts stdout "-------------------------------------------------------"
54		set lines [split $result "\n"]
55		set label RESULT
56		foreach i $lines {
57			if {$i != ""} {
58    			puts stdout " $label | \$result => $i"
59				set label "      "
60			}
61		}
62		puts stdout "======================================================="
63		error "tests aborted"
64    }
65}
66
67# ----------------------------------------------------------------------
68#  USAGE:  test_cmp_nums <num1> <num2>
69#
70#  Compares two numbers to see if they are "equal."  Numbers are
71#  "equal" if they have an absolute value greater than 1.0e-6 and they
72#  have at least 5 significant figures.  Returns 1/0 for true/false.
73# ----------------------------------------------------------------------
74proc test_cmp_nums {num1 num2} {
75	global TEST_ABS_TOL TEST_REL_TOL
76
77	if {[expr abs($num1)] > $TEST_ABS_TOL &&
78	    [expr abs($num2)] > $TEST_ABS_TOL} {
79		set avg [expr 0.5*($num1+$num2)]
80		set diff [expr abs(($num1-$num2)/$avg)]
81
82		if {$diff > $TEST_REL_TOL} {
83			return 0
84		}
85	}
86	return 1
87}
88
89# ----------------------------------------------------------------------
90#  USAGE:  test_cmp_vectors <list1> <list2>
91#
92#  Compares two lists of numbers to see if they are "equal."  Vectors
93#  are "equal" if elements are "equal" in the numeric sense.
94#  Returns 1/0 for true/false.
95# ----------------------------------------------------------------------
96proc test_cmp_vectors {list1 list2} {
97	if {[llength $list1] != [llength $list2]} {
98		return 0
99	}
100	for {set i 0} {$i < [llength $list1]} {incr i} {
101		set n1 [lindex $list1 $i]
102		set n2 [lindex $list2 $i]
103
104		if {![test_cmp_nums $n1 $n2]} {
105			return 0
106		}
107	}
108	return 1
109}
110
111# ----------------------------------------------------------------------
112#  USAGE:  test_cmp_lists <list1> <list2>
113#
114#  Compares two lists to see if they are "equal."  Lists are "equal"
115#  if they contain exactly the same elements, but perhaps in a
116#  different order.  Returns 1/0 for true/false.
117# ----------------------------------------------------------------------
118proc test_cmp_lists {list1 list2} {
119	if {[llength $list1] != [llength $list2]} {
120		return 0
121	}
122	foreach elem $list1 {
123		set i [lsearch $list2 $elem]
124		if {$i >= 0} {
125			set list2 [lreplace $list2 $i $i]
126		} else {
127			return 0
128		}
129	}
130	return 1
131}
132