1# 2# testutils.tcl -- 3# 4# Auxilliary utilities for use with the tcltest package. 5# Author: Joe English <jenglish@flightlab.com> 6# Version: 1.1 7# 8# This file is hereby placed in the public domain. 9# 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: 1 if 'script' correctly fails, raises 51# 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 if {![string match $pattern $result]} { 64 return -code error \ 65 "Error message '$rmsg' does not match '$pattern'" 66 } 67 return $rc 68} 69 70# testPackage package ?version? 71# Loads specified package with 'package require $package $version', 72# then prints message describing how the package was loaded. 73# 74# This is useful when you've got several versions of a 75# package to lying around and want to make sure you're 76# testing the right one. 77# 78 79proc testPackage {package {version ""}} { 80 if {![catch "package present $package $version"]} { return } 81 set rc [catch "package require $package $version" result] 82 if {$rc} { return -code $rc $result } 83 set version $result 84 set loadScript [package ifneeded $package $version] 85 puts $::tcltest::outputChannel \ 86 "Loaded $package version $version via {$loadScript}" 87 return; 88} 89 90#*EOF* 91