blob: e80a1d61a3dd391bd0810cd84db04d154e849a41 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
#
# Tests for chaining methods and procs
# ----------------------------------------------------------------------
# AUTHOR: Michael J. McLennan
# Bell Labs Innovations for Lucent Technologies
# mmclennan@lucent.com
# http://www.tcltk.com/itcl
# ----------------------------------------------------------------------
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
# ======================================================================
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Chaining methods and procs
# ----------------------------------------------------------------------
test chain-1.1 {define simple classes with inheritance} {
itcl::class test_chain_a {
constructor {args} {
#
eval chain $args
} {
global ::test_chain_status
lappend test_chain_status "a::constructor $args"
}
method show {mesg} {
chain $mesg
global ::test_chain_status
lappend test_chain_status "a::show $mesg"
}
proc tell {mesg} {
global ::test_chain_status
lappend test_chain_status "a::tell $mesg"
chain $mesg
}
}
itcl::class test_chain_b {
constructor {args} {
#
eval chain $args
} {
global ::test_chain_status
lappend test_chain_status "b::constructor $args"
}
method show {mesg} {
chain $mesg
global ::test_chain_status
lappend test_chain_status "b::show $mesg"
}
proc tell {mesg} {
global ::test_chain_status
lappend test_chain_status "b::tell $mesg"
chain $mesg
}
}
itcl::class test_chain_c {
inherit test_chain_a test_chain_b
constructor {args} {
eval chain $args
} {
global ::test_chain_status
lappend test_chain_status "c::constructor $args"
}
proc tell {mesg} {
global ::test_chain_status
lappend test_chain_status "c::tell $mesg"
chain $mesg
}
}
itcl::class test_chain_d {
inherit test_chain_c
constructor {args} {
eval chain $args
} {
global ::test_chain_status
lappend test_chain_status "d::constructor $args"
}
method show {mesg} {
chain $mesg
global ::test_chain_status
lappend test_chain_status "d::show $mesg"
}
proc tell {mesg} {
global ::test_chain_status
lappend test_chain_status "d::tell $mesg"
chain $mesg
}
}
} ""
test chain-1.2 {create a test object} {
set test_chain_status ""
set testobj [test_chain_d #auto 1 2 3]
set test_chain_status
} {{b::constructor 1 2 3} {a::constructor 1 2 3} {c::constructor 1 2 3} {d::constructor 1 2 3}}
test chain-1.3 {invoke a chained method} {
set test_chain_status ""
$testobj show "hello there"
set test_chain_status
} {{b::show hello there} {a::show hello there} {d::show hello there}}
test chain-1.4 {invoke a chained method with a specific name} {
set test_chain_status ""
$testobj test_chain_d::show "hello there"
set test_chain_status
} {{b::show hello there} {a::show hello there} {d::show hello there}}
test chain-1.5 {chained methods can cross multiple-inheritance branches} {
set test_chain_status ""
$testobj test_chain_a::show "hello there"
set test_chain_status
} {{b::show hello there} {a::show hello there}}
test chain-1.6 {invoke a chained proc} {
set test_chain_status ""
test_chain_d::tell "testing 1 2 3"
set test_chain_status
} {{d::tell testing 1 2 3} {c::tell testing 1 2 3} {a::tell testing 1 2 3}}
test chain-1.7 {invoke a chained proc} {
set test_chain_status ""
test_chain_c::tell "testing 1 2 3"
set test_chain_status
} {{c::tell testing 1 2 3} {a::tell testing 1 2 3}}
test chain-2.1 {create a test object in a base class} {
set test_chain_status ""
set testobj [test_chain_c #auto 4 5 6]
set test_chain_status
} {{b::constructor 4 5 6} {a::constructor 4 5 6} {c::constructor 4 5 6}}
test chain-2.2 {invoke a chained method} {
set test_chain_status ""
$testobj show "hello there"
set test_chain_status
} {{b::show hello there} {a::show hello there}}
test chain-3.0 {invoke "chain" outside of a class} {
list [catch {itcl::builtin::chain 1 2 3} err] $err
} {1 {cannot chain functions outside of a class context}}
test chain-4.0 {[35a5baca67]} -setup {
unset -nocomplain ::answer
itcl::class B {method act args {lappend ::answer B}}
itcl::class D {inherit B; method act args {lappend ::answer D; chain}}
} -body {
[D d] act Now!
set ::answer
} -cleanup {
itcl::delete class B
unset -nocomplain ::answer
} -result {D B}
# ----------------------------------------------------------------------
# Clean up
# ----------------------------------------------------------------------
itcl::delete class test_chain_d test_chain_c test_chain_b test_chain_a
::tcltest::cleanupTests
return
|
