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