1# 2# Tests for "body" and "configbody" commands 3# ---------------------------------------------------------------------- 4# AUTHOR: Michael J. McLennan 5# Bell Labs Innovations for Lucent Technologies 6# mmclennan@lucent.com 7# http://www.tcltk.com/itcl 8# 9# RCS: $Id: body.test,v 1.4 2004/02/12 18:09:50 davygrvy Exp $ 10# ---------------------------------------------------------------------- 11# Copyright (c) 1993-1998 Lucent Technologies, Inc. 12# ====================================================================== 13# See the file "license.terms" for information on usage and 14# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 16if {[lsearch [namespace children] ::tcltest] == -1} { 17 package require tcltest 2.1 18 namespace import -force ::tcltest::test 19} 20 21::tcltest::loadTestedCommands 22 23# ---------------------------------------------------------------------- 24# Test "body" command 25# ---------------------------------------------------------------------- 26test body-1.1 {define a class with missing bodies and arg lists} { 27 itcl::class test_body { 28 constructor {args} {} 29 destructor {} 30 31 method any 32 method zero {} 33 method one {x} 34 method two {x y} 35 method defvals {x {y 0} {z 1}} 36 method varargs {x args} 37 38 method override {mesg} { 39 return "override: $mesg" 40 } 41 } 42} "" 43 44test body-1.2 {cannot use methods without a body} { 45 test_body #auto 46 list [catch "test_body0 any" msg] $msg 47} {1 {member function "::test_body::any" is not defined and cannot be autoloaded}} 48 49test body-1.3 {check syntax of "body" command} { 50 list [catch "itcl::body test_body::any" msg] $msg 51} {1 {wrong # args: should be "itcl::body class::func arglist body"}} 52 53test body-1.4 {make sure members are found correctly} { 54 list [catch "itcl::body test_body::xyzzyxyzzyxyzzy {} {}" msg] $msg 55} {1 {function "xyzzyxyzzyxyzzy" is not defined in class "::test_body"}} 56 57test body-1.5a {members without an argument list can have any args} { 58 itcl::body test_body::any {} {return "any"} 59 list [catch "test_body0 any" msg] $msg 60} {0 any} 61 62test body-1.5b {members without an argument list can have any args} { 63 itcl::body test_body::any {x} {return "any: $x"} 64 list [catch "test_body0 any 1" msg] $msg 65} {0 {any: 1}} 66 67test body-1.5c {members without an argument list can have any args} { 68 itcl::body test_body::any {x {y 2}} {return "any: $x $y"} 69 list [catch "test_body0 any 1" msg] $msg 70} {0 {any: 1 2}} 71 72test body-1.6a {an empty argument list must stay empty} { 73 list [catch {itcl::body test_body::zero {x y} {return "zero: $x $y"}} msg] $msg 74} {1 {argument list changed for function "::test_body::zero": should be ""}} 75 76test body-1.6b {an empty argument list must stay empty} { 77 list [catch {itcl::body test_body::zero {} {return "zero"}} msg] $msg 78} {0 {}} 79 80test body-1.7a {preserve argument list: fixed arguments} { 81 list [catch {itcl::body test_body::one {x y} {return "one: $x $y"}} msg] $msg 82} {1 {argument list changed for function "::test_body::one": should be "x"}} 83 84test body-1.7b {preserve argument list: fixed arguments} { 85 list [catch {itcl::body test_body::one {a} {return "one: $a"}} msg] $msg 86} {0 {}} 87 88test body-1.7c {preserve argument list: fixed arguments} { 89 list [catch "test_body0 one 1.0" msg] $msg 90} {0 {one: 1.0}} 91 92test body-1.8a {preserve argument list: fixed arguments} { 93 list [catch {itcl::body test_body::two {x} {return "two: $x"}} msg] $msg 94} {1 {argument list changed for function "::test_body::two": should be "x y"}} 95 96test body-1.8b {preserve argument list: fixed arguments} { 97 list [catch {itcl::body test_body::two {a b} {return "two: $a $b"}} msg] $msg 98} {0 {}} 99 100test body-1.8c {preserve argument list: fixed arguments} { 101 list [catch "test_body0 two 2.0 3.0" msg] $msg 102} {0 {two: 2.0 3.0}} 103 104test body-1.9a {preserve argument list: default arguments} { 105 list [catch {itcl::body test_body::defvals {x} {}} msg] $msg 106} {1 {argument list changed for function "::test_body::defvals": should be "x {y 0} {z 1}"}} 107 108test body-1.9b {preserve argument list: default arguments} { 109 list [catch {itcl::body test_body::defvals {a {b 0} {c 2}} {}} msg] $msg 110} {1 {argument list changed for function "::test_body::defvals": should be "x {y 0} {z 1}"}} 111 112test body-1.9c {preserve argument list: default arguments} { 113 list [catch {itcl::body test_body::defvals {a {b 0} {c 1}} {}} msg] $msg 114} {0 {}} 115 116test body-1.10a {preserve argument list: variable arguments} { 117 list [catch {itcl::body test_body::varargs {} {}} msg] $msg 118} {1 {argument list changed for function "::test_body::varargs": should be "x args"}} 119 120test body-1.10b {preserve argument list: variable arguments} { 121 list [catch {itcl::body test_body::varargs {a} {}} msg] $msg 122} {0 {}} 123 124test body-1.10c {preserve argument list: variable arguments} { 125 list [catch {itcl::body test_body::varargs {a b c} {}} msg] $msg 126} {0 {}} 127 128test body-1.11 {redefined body really does change} { 129 list [test_body0 override "test #1"] \ 130 [itcl::body test_body::override {text} {return "new: $text"}] \ 131 [test_body0 override "test #2"] 132} {{override: test #1} {} {new: test #2}} 133 134# ---------------------------------------------------------------------- 135# Test "body" command with inheritance 136# ---------------------------------------------------------------------- 137test body-2.1 {inherit from a class with missing bodies} { 138 itcl::class test_ibody { 139 inherit test_body 140 method zero {} 141 } 142 test_ibody #auto 143} {test_ibody0} 144 145test body-2.2 {redefine a method in a derived class} { 146 itcl::body test_ibody::zero {} {return "ibody zero"} 147 list [test_ibody0 info function zero] \ 148 [test_ibody0 info function test_body::zero] 149} {{public method ::test_ibody::zero {} {return "ibody zero"}} {public method ::test_body::zero {} {return "zero"}}} 150 151test body-2.3 {try to redefine a method that was not declared} { 152 list [catch {itcl::body test_ibody::one {x} {return "new"}} msg] $msg 153} {1 {function "one" is not defined in class "::test_ibody"}} 154 155# ---------------------------------------------------------------------- 156# Test "configbody" command 157# ---------------------------------------------------------------------- 158test body-3.1 {define a class with public variables} { 159 itcl::class test_cbody { 160 private variable priv 161 protected variable prot 162 163 public variable option {} { 164 lappend messages "option: $option" 165 } 166 public variable nocode {} 167 public common messages 168 } 169} "" 170 171test body-3.2 {check syntax of "configbody" command} { 172 list [catch "itcl::configbody test_cbody::option" msg] $msg 173} {1 {wrong # args: should be "itcl::configbody class::option body"}} 174 175test body-3.3 {make sure that members are found correctly} { 176 list [catch "itcl::configbody test_cbody::xyzzy {}" msg] $msg 177} {1 {option "xyzzy" is not defined in class "::test_cbody"}} 178 179test body-3.4 {private variables have no config code} { 180 list [catch "itcl::configbody test_cbody::priv {bogus}" msg] $msg 181} {1 {option "::test_cbody::priv" is not a public configuration option}} 182 183test body-3.5 {protected variables have no config code} { 184 list [catch "itcl::configbody test_cbody::prot {bogus}" msg] $msg 185} {1 {option "::test_cbody::prot" is not a public configuration option}} 186 187test body-3.6 {can use public variables without a body} { 188 test_cbody #auto 189 list [catch "test_cbody0 configure -nocode 1" msg] $msg 190} {0 {}} 191 192test body-3.7 {redefined body really does change} { 193 list [test_cbody0 configure -option "hello"] \ 194 [itcl::configbody test_cbody::option {lappend messages "new: $option"}] \ 195 [test_cbody0 configure -option "goodbye"] \ 196 [set test_cbody::messages] \ 197} {{} {} {} {{option: hello} {new: goodbye}}} 198 199# ---------------------------------------------------------------------- 200# Test "configbody" command with inheritance 201# ---------------------------------------------------------------------- 202test body-4.1 {inherit from a class with missing config bodies} { 203 itcl::class test_icbody { 204 inherit test_cbody 205 public variable option "icbody" 206 } 207 test_icbody #auto 208} {test_icbody0} 209 210test body-4.2 {redefine a body in a derived class} { 211 itcl::configbody test_icbody::option {lappend messages "test_icbody: $option"} 212 list [test_icbody0 info variable option] \ 213 [test_icbody0 info variable test_cbody::option] 214} {{public variable ::test_icbody::option icbody {lappend messages "test_icbody: $option"} icbody} {public variable ::test_cbody::option {} {lappend messages "new: $option"} {}}} 215 216test body-4.3 {try to redefine a body for a variable that was not declared} { 217 list [catch {itcl::configbody test_icbody::nocode {return "new"}} msg] $msg 218} {1 {option "nocode" is not defined in class "::test_icbody"}} 219 220# ---------------------------------------------------------------------- 221# Clean up 222# ---------------------------------------------------------------------- 223itcl::delete class test_body test_cbody 224 225::tcltest::cleanupTests 226return 227