1# assert.tcl --
2#
3#	The [assert] command of the package "control".
4#
5# RCS: @(#) $Id: assert.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $
6
7namespace eval ::control {
8
9    namespace eval assert {
10	namespace export EnabledAssert DisabledAssert
11	variable CallbackCmd [list return -code error]
12
13	namespace import [namespace parent]::no-op
14	rename no-op DisabledAssert
15
16	proc EnabledAssert {expr args} {
17	    variable CallbackCmd
18
19	    set code [catch {uplevel 1 [list expr $expr]} res]
20	    if {$code} {
21		return -code $code $res
22	    }
23	    if {![string is boolean -strict $res]} {
24		return -code error "invalid boolean expression: $expr"
25	    }
26	    if {$res} {return}
27	    if {[llength $args]} {
28		set msg [join $args]
29	    } else {
30		set msg "assertion failed: $expr"
31	    }
32	    # Might want to catch this
33	    namespace eval :: $CallbackCmd [list $msg]
34	}
35
36	proc enabled {args} {
37	    set n [llength $args]
38	    if {$n > 1} {
39		return -code error "wrong # args: should be\
40			\"[lindex [info level 0] 0] ?boolean?\""
41	    }
42	    if {$n} {
43		set val [lindex $args 0]
44		if {![string is boolean -strict $val]} {
45		    return -code error "invalid boolean value: $val"
46		}
47		if {$val} {
48		    [namespace parent]::AssertSwitch Disabled Enabled
49		} else {
50		    [namespace parent]::AssertSwitch Enabled Disabled
51		}
52	    } else {
53		return [string equal [namespace origin EnabledAssert] \
54			[namespace origin [namespace parent]::assert]]
55	    }
56	    return ""
57	}
58
59	proc callback {args} {
60	    set n [llength $args]
61	    if {$n > 1} {
62		return -code error "wrong # args: should be\
63			\"[lindex [info level 0] 0] ?command?\""
64	    }
65	    if {$n} {
66	        return [variable CallbackCmd [lindex $args 0]]
67	    }
68	    variable CallbackCmd
69	    return $CallbackCmd
70	}
71
72    }
73
74    proc AssertSwitch {old new} {
75	if {[string equal [namespace origin assert] \
76		[namespace origin assert::${new}Assert]]} {return}
77	rename assert ${old}Assert
78	rename ${new}Assert assert
79    }
80
81    namespace import assert::DisabledAssert assert::EnabledAssert
82
83    # For indexer
84    proc assert args #
85    rename assert {}
86
87    # Initial default: disabled asserts
88    rename DisabledAssert assert
89
90}
91
92