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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
# -*- Tcl -*-
package prefer latest
package require nx
set ::tcl86 [package vsatisfies [package req Tcl] 8.6-]
#
# Intentionally, we do not want to make a "namespace import" in this
# test file. Run this file via a pure tclsh!
#
namespace path nx
# Don't use test, since both, package test and contains redefine "new",
# so we have a conflict....
proc ? {cmd expected {msg ""}} {
#puts "??? $cmd"
set r [uplevel $cmd]
if {$msg eq ""} {set msg $cmd}
if {$r ne $expected} {
puts stderr "ERROR $msg returned '$r' ne '$expected'"
error "FAILED $msg returned '$r' ne '$expected'"
} else {
puts stderr "OK $msg"
}
}
#
# We define here a few attributes of type method, such we can add
# arbitrary "-" calls
#
Class create Tree {
:property label
:property contains:alias
:property foo:alias
:public method foo {arg} {set :x $arg}
}
set y [Tree new -foo hu]
? [list $y eval {set :x}] hu
#
# actually, the intention was to define an xotcl-like -contains
#
set x [Tree create 1 -label 1 -contains {
? {self} ::1
? {namespace current} ::1
Tree create 1.1 -label 1.1
Tree create 1.2 -label 1.2 -contains {
? {self} ::1::1.2
? {namespace current} ::1::1.2
Tree create 1.2.1 -label 1.2.1
Tree create 1.2.2 -label 1.2.2 -contains {
Tree create 1.2.2.1 -label 1.2.2.1
? {self} ::1::1.2::1.2.2
}
Tree create 1.2.3 -label 1.2.3
}
Tree create 1.3 -label 1.3
}]
set x [Tree create t -contains {
? {Tree create branch} ::t::branch
? {Tree new} ::t::__#1
}]
#
# error and errorcode propagation from within contains
#
Class create Arbre
? {catch {Arbre create root {
:contains {
Arbre create level1 {
:contains {
Arbre level2
}
}
}
}} msg opts; set msg} "method 'level2' unknown for ::Arbre; in order to create an instance of class ::Arbre, consider using '::Arbre create level2 ?...?'"
Class create Arbre
? {catch {Arbre create root {
:contains {
Arbre create level1 {
:contains {
return -code error -errorcode MYERR
}
}
}
}} msg opts; dict get $opts -errorcode} "MYERR"
#
# Test resolving next without namespace import/path
#
namespace path ""
# make sure, we have no "::next" defined or globally imported
? {info command ::next} ""
nx::Class create C {
:public method foo {} {next; return 12}
:create c1
}
? {c1 foo} 12
? {c1 foo} 12
C create c2 {
set :s [self]
set :c [current]
:public object method bar {} {return "[set :s]-[set :c]"}
}
? {c2 bar} "::c2-::c2"
#
# Test potential crash, when methodNamePath is computed without a
# stack frame
#
C public method foo {{-new 0} name value} { return $value}
catch {c1 foo -name a b} errMsg
? {set errMsg} \
{invalid argument 'b', maybe too many arguments; should be "::c1 foo ?-new /value/? /name/ /value/"}
# Test resolving of implicit namespaces in relationcmds (here
# superclass) in the nx namespace.
namespace path ""
namespace eval ::nx {
#puts stderr =====1
set c [Class create C -superclass Class {
:object method foo {} {;}
}]
? {set c} ::C
# recreate
set c [Class create C -superclass Class ]
? {set c} ::C
#puts stderr =====3
}
#
# Forget and reload nx
#
#puts ====NX-[package versions nx]-[set auto_path]
package forget nx
package req nx
#puts ====XOTCL-[package versions XOTcl]-[set auto_path]
package require XOTcl 2.0
package forget XOTcl
package require XOTcl 2.0
########################################################################
#
# Test that we do not allow one to mix object systems within the intrinsic
# classes of an object. Otherwise we would have problems with the
# recreate "C0 create c0". On a recreate of c0 the object system for
# C0 is ::xotcl, therefore, we try to call recreate. In the C0 class
# hierarchy is from nx and contains no "recreate" method.
? {catch {::xotcl::Class create C0 -superclass ::nx::Object} errorMsg} 1
? {set ::errorMsg} {class "::C0" has a different object system as class "::nx::Object"}
::nx::Class create C1 -superclass ::nx::Object
# trigger the call of "cleanup" to work via method dispatch
::xotcl::Object create o1
o1 proc cleanup {} {puts stderr "CLEANUP"; return}
#C0 create c0
#C0 create c0
C1 create c1
C1 create c1
c1 destroy
C1 destroy
? {nx::Object create o} ::o
? {o contains { nx::Object create p}} ::o::p
? {catch {o contains { return -code error -errorcode {FOO bar baz} somethingwrong}} errorMsg} 1
set ::errorinfo $::errorInfo
set ::errorcode $::errorCode
? {set ::errorMsg} {somethingwrong}
if {$::tcl86} {
set r {somethingwrong
while executing
"o contains { return -code error -errorcode {FOO bar baz} somethingwrong}"}
} else {
set r {somethingwrong
::o ::nx::Object->contains
invoked from within
"o contains { return -code error -errorcode {FOO bar baz} somethingwrong}"}
}
? {set ::errorinfo} $r
? {set ::errorcode} {FOO bar baz}
puts stderr "====EXIT [info script]"
#
# Local variables:
# mode: tcl
# tcl-indent-level: 2
# indent-tabs-mode: nil
# End:
|
