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