blob: 4b5833710cc96b082a5e874b9355a054cdb8df05 (
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
|
/*
* 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.
*/
#ifndef TCL_OO_SCRIPT_H
#define TCL_OO_SCRIPT_H
/*
* The scripted part of the definitions of TclOO.
*/
static const char *tclOOSetupScript =
"::proc ::oo::Helpers::callback {method args} {\n"
" list [uplevel 1 {namespace which my}] $method {*}$args\n"
"}\n"
"::proc ::oo::Helpers::mymethod {method args} {\n"
" list [uplevel 1 {namespace which my}] $method {*}$args\n"
"}\n"
"::proc ::oo::Helpers::classvariable {name args} {\n"
" # Get a reference to the class's namespace\n"
" set ns [info object namespace [uplevel 1 {self class}]]\n"
" # Double up the list of variable names\n"
" foreach v [list $name {*}$args] {\n"
" if {[string match *(*) $v]} {\n"
" return -code error [string cat {bad variable name \"} $v {\": can\'t create a scalar variable that looks like an array element}]\n"
" }\n"
" if {[string match *::* $v]} {\n"
" return -code error [string cat {bad variable name \"} $v {\": can\'t create a local variable with a namespace separator in it}]\n"
" }\n"
" lappend vs $v $v\n"
" }\n"
" # Lastly, link the caller's local variables to the class's variables\n"
" tailcall namespace upvar $ns {*}$vs\n"
"}\n"
"::proc ::oo::Helpers::link {args} {\n"
" set ns [uplevel 1 {namespace current}]\n"
" foreach link $args {\n"
" if {[llength $link] == 2} {\n"
" lassign $link src dst\n"
" } else {\n"
" lassign $link src\n"
" set dst $src\n"
" }\n"
" if {![string match ::* $src]} {\n"
" set src [string cat $ns :: $src]\n"
" }\n"
" interp alias {} $src {} ${ns}::my $dst\n"
" trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src]\n"
" }\n"
" return\n"
"}\n"
"::proc ::oo::Helpers::Unlink {cmd args} {\n"
" if {[namespace which $cmd] ne {}} {\n"
" rename $cmd {}\n"
" }\n"
"}\n"
"::proc ::oo::DelegateName {class} {\n"
" string cat [info object namespace $class] {:: oo ::delegate}\n"
"}\n"
"proc ::oo::define::classmethod {name {args {}} {body {}}} {\n"
" # Create the method on the class if the caller gave arguments and body\n"
" set argc [llength [info level 0]]\n"
" if {$argc == 3} {\n"
" return -code error [string cat {wrong # args: should be \"}"
" [lindex [info level 0] 0] { name ?args body?\"}]\n"
" }\n"
" set cls [uplevel 1 self]\n"
" if {$argc == 4} {\n"
" ::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
" }\n"
" # Make the connection by forwarding\n"
" tailcall forward $name myclass $name\n"
"}\n"
"proc ::oo::MixinClassDelegates {class} {\n"
" if {![info object isa class $class]} {\n"
" return\n"
" }\n"
" set delegate [::oo::DelegateName $class]\n"
" if {![info object isa class $delegate]} {\n"
" return\n"
" }\n"
" foreach c [info class superclass $class] {"
" set d [::oo::DelegateName $c]\n"
" if {![info object isa class $d]} {\n"
" continue\n"
" }\n"
" ::oo::define $delegate superclass -append $d\n"
" }\n"
" ::oo::objdefine $class mixin -append $delegate\n"
"}\n"
"::proc ::oo::define::initialise {body} {\n"
" set clsns [info object namespace [uplevel 1 self]]\n"
" tailcall apply [list {} $body $clsns]\n"
"}\n"
"::oo::define ::oo::Slot {\n"
" method Get {} {return -code error unimplemented}\n"
" method Set list {return -code error unimplemented}\n"
" method -set args {tailcall my Set $args}\n"
" method -append args {\n"
" set current [uplevel 1 [list [namespace which my] Get]]\n"
" tailcall my Set [list {*}$current {*}$args]\n"
" }\n"
" method -clear {} {tailcall my Set {}}\n"
" forward --default-operation my -append\n"
" method unknown {args} {\n"
" set def --default-operation\n"
" if {[llength $args] == 0} {\n"
" tailcall my $def\n"
" } elseif {![string match -* [lindex $args 0]]} {\n"
" tailcall my $def {*}$args\n"
" }\n"
" next {*}$args\n"
" }\n"
" export -set -append -clear\n"
" unexport unknown destroy\n"
"}\n"
"\n"
"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"
"::oo::define ::oo::class method <cloned> {originObject} {\n"
" next $originObject\n"
" # Rebuild the class inheritance delegation class\n"
" set originDelegate [::oo::DelegateName $originObject]\n"
" set targetDelegate [::oo::DelegateName [self]]\n"
" if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {\n"
" ::oo::copy $originDelegate $targetDelegate\n"
" ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {\n"
" if {$c eq $originDelegate} {set targetDelegate} {set c}\n"
" }]\n"
" }\n"
"}\n"
"::oo::class create ::oo::singleton {\n"
" superclass ::oo::class\n"
" variable object\n"
" unexport create createWithNamespace\n"
" method new args {\n"
" if {![info exists object] || ![info object isa object $object]} {\n"
" set object [next {*}$args]\n"
" ::oo::objdefine $object method destroy {} {\n"
" return -code error {may not destroy a singleton object}\n"
" }\n"
" ::oo::objdefine $object method <cloned> {originObject} {\n"
" return -code error {may not clone a singleton object}\n"
" }\n"
" }\n"
" return $object\n"
" }\n"
"}\n"
"::oo::class create ::oo::abstract {\n"
" superclass ::oo::class\n"
" unexport create createWithNamespace new\n"
"}\n"
;
/*
* The body of the <cloned> method of oo::object.
*/
static const char *clonedBody =
"# Copy over the procedures from the original namespace\n"
"foreach p [info procs [info object namespace $originObject]::*] {\n"
" set args [info args $p]\n"
" set idx -1\n"
" foreach a $args {\n"
" lset args [incr idx]"
" [if {[info default $p $a d]} {list $a $d} {list $a}]\n"
" }\n"
" set b [info body $p]\n"
" set p [namespace tail $p]\n"
" proc $p $args $b\n"
"}\n"
"# Copy over the variables from the original namespace\n"
"foreach v [info vars [info object namespace $originObject]::*] {\n"
" upvar 0 $v vOrigin\n"
" namespace upvar [namespace current] [namespace tail $v] vNew\n"
" if {[info exists vOrigin]} {\n"
" if {[array exists vOrigin]} {\n"
" array set vNew [array get vOrigin]\n"
" } else {\n"
" set vNew $vOrigin\n"
" }\n"
" }\n"
"}\n"
;
#endif /* TCL_OO_SCRIPT_H */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
