blob: 73c3383130a98993df39e2e62230c9c67f3ab5d6 (
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
|
/*
* 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"
" set vs [list $name $name]\n"
" foreach v $args {lappend vs $v $v}\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"
" interp alias {} ${ns}::$src {} ${ns}::my $dst\n"
" }\n"
" return\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 [info object namespace $cls]::my $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]} {\n"
" set object [next {*}$args]\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:
*/
|
