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