blob: c0b4d1fac33ba2b2009e24258c6352ae12a99720 (
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
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
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
|
# tclOOScript.h --
#
# This file contains support scripts for TclOO. They are defined here so
# that the code can be definitely run even in safe interpreters; TclOO's
# core setup is safe.
#
# Copyright (c) 2012-2018 Donal K. Fellows
# Copyright (c) 2013 Andreas Kupries
# Copyright (c) 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
::namespace eval ::oo::Helpers {
::namespace path {}
proc callback {method args} {
list [uplevel 1 {::namespace which my}] $method {*}$args
}
proc mymethod {method args} {
list [uplevel 1 {::namespace which my}] $method {*}$args
}
proc classvariable {name args} {
# Get a reference to the class's namespace
set ns [info object namespace [uplevel 1 {self class}]]
# Double up the list of variable names
foreach v [list $name {*}$args] {
if {[string match *(*) $v]} {
variable
return -code error [format \
{bad variable name "%s": can't create a scalar variable that looks like an array element} \
$v]
}
if {[string match *::* $v]} {
return -code error [format \
{bad variable name "%s": can't create a local variable with a namespace separator in it} \
$v]
}
lappend vs $v $v
}
# Lastly, link the caller's local variables to the class's variables
tailcall namespace upvar $ns {*}$vs
}
proc link {args} {
set ns [uplevel 1 {::namespace current}]
foreach link $args {
if {[llength $link] == 2} {
lassign $link src dst
} else {
lassign $link src
set dst $src
}
if {![string match ::* $src]} {
set src [string cat $ns :: $src]
}
interp alias {} $src {} ${ns}::my $dst
trace add command ${ns}::my delete [list \
::oo::UnlinkLinkedCommand $src]
}
return
}
}
::namespace eval ::oo {
proc UnlinkLinkedCommand {cmd args} {
if {[namespace which $cmd] ne {}} {
rename $cmd {}
}
}
proc DelegateName {class} {
string cat [info object namespace $class] {:: oo ::delegate}
}
proc MixinClassDelegates {class} {
if {![info object isa class $class]} {
return
}
set delegate [DelegateName $class]
if {![info object isa class $delegate]} {
return
}
foreach c [info class superclass $class] {
set d [DelegateName $c]
if {![info object isa class $d]} {
continue
}
define $delegate superclass -append $d
}
objdefine $class mixin -append $delegate
}
proc UpdateClassDelegatesAfterClone {originObject targetObject} {
# Rebuild the class inheritance delegation class
set originDelegate [DelegateName $originObject]
set targetDelegate [DelegateName $targetObject]
if {
[info object isa class $originDelegate]
&& ![info object isa class $targetDelegate]
} then {
copy $originDelegate $targetDelegate
objdefine $targetObject mixin -set \
{*}[lmap c [info object mixin $targetObject] {
if {$c eq $originDelegate} {set targetDelegate} {set c}
}]
}
}
}
::namespace eval ::oo::define {
::proc classmethod {name {args {}} {body {}}} {
# Create the method on the class if the caller gave arguments and body
::set argc [::llength [::info level 0]]
::if {$argc == 3} {
::return -code error [::format \
{wrong # args: should be "%s name ?args body?"} \
[::lindex [::info level 0] 0]]
}
::set cls [::uplevel 1 self]
::if {$argc == 4} {
::oo::define [::oo::DelegateName $cls] method $name $args $body
}
# Make the connection by forwarding
::tailcall forward $name myclass $name
}
::proc initialise {body} {
::set clsns [::info object namespace [::uplevel 1 self]]
::tailcall apply [::list {} $body $clsns]
}
# Make the initialise command appear with US spelling too
::namespace export initialise
::namespace eval tmp {::namespace import ::oo::define::initialise}
::rename ::oo::define::tmp::initialise initialize
::namespace delete tmp
::namespace export -clear
}
::oo::define ::oo::Slot {
method Get {} {return -code error unimplemented}
method Set list {return -code error unimplemented}
method -set args {tailcall my Set $args}
method -append args {
set current [uplevel 1 [list [namespace which my] Get]]
tailcall my Set [list {*}$current {*}$args]
}
method -clear {} {tailcall my Set {}}
forward --default-operation my -append
method unknown {args} {
set def --default-operation
if {[llength $args] == 0} {
tailcall my $def
} elseif {![string match -* [lindex $args 0]]} {
tailcall my $def {*}$args
}
next {*}$args
}
export -set -append -clear
unexport unknown destroy
}
::oo::objdefine ::oo::define::superclass forward --default-operation my -set
::oo::objdefine ::oo::define::mixin forward --default-operation my -set
::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set
::oo::define ::oo::object method <cloned> {originObject} {
# Copy over the procedures from the original namespace
foreach p [info procs [info object namespace $originObject]::*] {
set args [info args $p]
set idx -1
foreach a $args {
if {[info default $p $a d]} {
lset args [incr idx] [list $a $d]
} else {
lset args [incr idx] [list $a]
}
}
set b [info body $p]
set p [namespace tail $p]
proc $p $args $b
}
# Copy over the variables from the original namespace
foreach v [info vars [info object namespace $originObject]::*] {
upvar 0 $v vOrigin
namespace upvar [namespace current] [namespace tail $v] vNew
if {[info exists vOrigin]} {
if {[array exists vOrigin]} {
array set vNew [array get vOrigin]
} else {
set vNew $vOrigin
}
}
}
# General commands, sub-namespaces and advancd variable config (traces,
# etc) are *not* copied over. Classes that want that should do it
# themselves.
}
::oo::define ::oo::class method <cloned> {originObject} {
next $originObject
# Rebuild the class inheritance delegation class
::oo::UpdateClassDelegatesAfterClone $originObject [self]
}
::oo::class create ::oo::singleton {
superclass ::oo::class
variable object
unexport create createWithNamespace
method new args {
if {![info exists object] || ![info object isa object $object]} {
set object [next {*}$args]
::oo::objdefine $object method destroy {} {
return -code error {may not destroy a singleton object}
}
::oo::objdefine $object method <cloned> {originObject} {
return -code error {may not clone a singleton object}
}
}
return $object
}
}
::oo::class create ::oo::abstract {
superclass ::oo::class
unexport create createWithNamespace new
}
# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End:
|
