1# testutils.tcl --
2#
3# 	Auxilliary utilities for use with the tcltest package.
4# 	Author: Joe English <jenglish@flightlab.com>
5# 	Version: 1.1
6#
7# This file is hereby placed in the public domain.
8#
9# $Id: testutils.tcl,v 1.3 2004/02/20 09:15:53 balls Exp $
10
11variable tracing 0		;# Set to '1' to enable the 'trace' command
12variable tracingErrors 0	;# If set, 'expectError' prints error messages
13
14# ok --
15#	Returns an empty string.
16#	May be used as the last statement in test scripts
17#	that are only evaluated for side-effects or in cases
18#	where you just want to make sure that an operation succeeds
19#
20proc ok {} { return {} }
21
22# result result --
23#	Just returns $result
24#
25proc result {result} { return $result }
26
27# tracemsg msg --
28#	Prints tracing message if $::tracing is nonzero.
29#
30proc tracemsg {string} {
31    if {$::tracing} {
32	puts $::tcltest::outputChannel $string
33    }
34}
35
36# assert expr ?msg? --
37#	Evaluates 'expr' and signals an error
38#	if the condition is not true.
39#
40proc assert {expr {message ""}} {
41    if {![uplevel 1 [list expr $expr]]} {
42	return -code error "Assertion {$expr} failed:\n$message"
43    }
44}
45
46# expectError script  ? pattern ? --
47#	Evaluate 'script', which is expected to fail
48#	with an error message matching 'pattern'.
49#
50#	Returns the error message if the script 'correctly' fails,
51#	raises an error otherwise
52
53proc expectError {script {pattern "*"}} {
54    set rc [catch [list uplevel 1 $script] result]
55    if {$::tracingErrors} {
56	puts stderr "==> [string replace $result 70 end ...]"
57    }
58    set rmsg [string replace $result 40 end ...]
59    if {$rc != 1} {
60	return -code error \
61	    "Expected error, got '$rmsg' (rc=$rc)"
62    }
63    return $result
64}
65
66# sortedarray --
67#
68#	Return the contents of an array, sorted by index
69
70proc sortedarray arrName {
71    upvar 1 $arrName thearray
72
73    set result {}
74    foreach idx [lsort [array names thearray]] {
75	lappend result $idx $thearray($idx)
76    }
77
78    return $result
79}
80
81# compareNodes
82#	Compares two nodes, taking implementations into account
83
84proc compareNodes {node1 node2} {
85    if {[::tcltest::testConstraint dom_libxml2] || [::tcltest::testConstraint dom_tcl]} {
86	::dom::node isSameNode $node1 $node2
87    } else {
88	return [expr ![string compare $node1 $node2]]
89    }
90}
91
92# compareNodeList list1 list2
93#	Compares two lists of DOM nodes, in an ordered fashion.
94#	NB. the node identities are compared, not their tokens.
95
96proc compareNodeList {list1 list2} {
97    if {[llength $list1] != [llength $list2]} {
98	return 0
99    }
100    foreach node1 $list1 node2 $list2 {
101	if {![compareNodes $node1 $node2]} {
102	    return 0
103	}
104    }
105    return 1
106}
107
108# compareNodeset set1 set2
109#	Compares two sets of DOM nodes, in an unordered fashion.
110#	NB. the node identities are compared, not their tokens.
111
112proc compareNodeset {set1 set2} {
113    if {[llength $set1] != [llength $set2]} {
114	return 0
115    }
116    foreach node1 [lsort $set1] node2 [lsort $set2] {
117	if {![compareNodes $node1 $node2]} {
118	    return 0
119	}
120    }
121    return 1
122}
123
124# checkTree doc list
125#	Tests that a DOM tree has a structure specified as a Tcl list
126
127proc checkTree {node spec {checktype 1}} {
128    if {[dom::node cget $node -nodeType] == "document"} {
129	if {$checktype} {
130	    if {[lindex [lindex $spec 0] 0] == "doctype"} {
131		set doctype [dom::document cget $node -doctype]
132		if {[dom::node cget $doctype -nodeType] != "documentType"} {
133		    return 0
134		}
135		if {[dom::documenttype cget $doctype -name] != [lindex [lindex $spec 0] 1]} {
136		    return 0
137		}
138		# Should also check external identifiers and internal subset
139		set spec [lrange $spec 1 end]
140	    }
141	}
142    }
143    foreach child [dom::node children $node] specchild $spec {
144	switch [lindex $specchild 0] {
145	    element {
146		if {[dom::node cget $child -nodeType] != "element"} {
147		    return 0
148		}
149		if {[dom::node cget $child -nodeName] != [lindex $specchild 1]} {
150		    return 0
151		}
152		foreach {name value} [lindex $specchild 2] {
153		    if {[dom::element getAttribute $child $name] != $value} {
154			return 0
155		    }
156		}
157		set result [checkTree $child [lindex $specchild 3]]
158		if {!$result} {
159		    return 0
160		}
161	    }
162	    pi {
163		if {[dom::node cget $child -nodeType] != "processingInstruction"} {
164		    return 0
165		}
166		if {[dom::node cget $child -nodeName] != [lindex $specchild 1]} {
167		    return 0
168		}
169	    }
170	    dtd {
171		if {[dom::node cget $child -nodeType] != "dtd"} {
172		    return 0
173		}
174	    }
175	    text {
176		if {[dom::node cget $child -nodeType] != "textNode"} {
177		    return 0
178		}
179		if {[dom::node cget $child -nodeValue] != [lindex $specchild 1]} {
180		    return 0
181		}
182	    }
183	    default {
184	    }
185	}
186    }
187
188    return 1
189}
190
191# testPackage package ?version?
192#	Loads specified package with 'package require $package $version',
193#	then prints message describing how the package was loaded.
194#
195#	This is useful when you've got several versions of a
196#	package to lying around and want to make sure you're
197#	testing the right one.
198#
199
200proc testPackage {package {version ""}} {
201    if {$package == "libxml2"} {
202	# "libxml2" is shorthand for xml::libxml2
203	set package xml::libxml2
204    }
205    if {![catch "package present $package $version"]} { return }
206    set rc [catch "package require $package $version" result]
207    if {$rc} { return -code $rc $result }
208    set version $result
209    set loadScript [package ifneeded $package $version]
210    puts $::tcltest::outputChannel \
211	"Loaded $package version $version via {$loadScript}"
212    return;
213}
214
215#*EOF*
216