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