Tcl Source Code

Check-in [0dadca8891]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Improve script compilation. Prove that compilation works with safe interps.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256:0dadca88917a17958ee32ebd6f510e6e1253c883375ffd7fe0c479327a5f9b21
User & Date: dkf 2018-08-11 11:18:20
Context
2018-08-11
12:01
Added a note about the genesis of the compiled header. check-in: fe3eeb39c3 user: dkf tags: tip-478
11:18
Improve script compilation. Prove that compilation works with safe interps. check-in: 0dadca8891 user: dkf tags: tip-478
2018-08-05
20:14
Combine the two bits of scripted code inside TclOO's definition into one. check-in: af7aa1c82c user: dkf tags: tip-478
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOOScript.h.

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
240
241
242
243

244
245
246
247
248
249
250
251
252
253
254
255
256
 
/*
 * The scripted part of the definitions of TclOO.
 */

static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */
"::namespace eval ::oo::Helpers {\n"
"    ::namespace path {}\n"
"\n"

"    proc callback {method args} {\n"
"        list [uplevel 1 {::namespace which my}] $method {*}$args\n"
"    }\n"
"\n"
"    proc mymethod {method args} {\n"
"        list [uplevel 1 {::namespace which my}] $method {*}$args\n"
"    }\n"
"\n"

"    proc 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"
"                variable \n"
"                return -code error [format \\\n"
"                    {bad variable name \"%s\": can\'t create a scalar variable that looks like an array element} \\\n"
"                    $v]\n"
"            }\n"



"            if {[string match *::* $v]} {\n"
"                return -code error [format \\\n"
"                    {bad variable name \"%s\": can\'t create a local variable with a namespace separator in it} \\\n"
"                    $v]\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"
"\n"
"    proc 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 \\\n"
"                ::oo::UnlinkLinkedCommand $src]\n"
"        }\n"

"        return\n"
"    }\n"
"}\n"
"\n"
"::namespace eval ::oo {\n"
"    proc UnlinkLinkedCommand {cmd args} {\n"
"        if {[namespace which $cmd] ne {}} {\n"
"            rename $cmd {}\n"
"        }\n"
"    }\n"
"\n"
"    proc DelegateName {class} {\n"
"        string cat [info object namespace $class] {:: oo ::delegate}\n"
"    }\n"
"\n"
"    proc MixinClassDelegates {class} {\n"
"        if {![info object isa class $class]} {\n"
"            return\n"
"        }\n"
"        set delegate [DelegateName $class]\n"
"        if {![info object isa class $delegate]} {\n"
"            return\n"
"        }\n"
"        foreach c [info class superclass $class] {\n"
"            set d [DelegateName $c]\n"
"            if {![info object isa class $d]} {\n"
"                continue\n"
"            }\n"

"            define $delegate superclass -append $d\n"
"        }\n"
"        objdefine $class mixin -append $delegate\n"
"    }\n"
"\n"
"    proc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
"        # Rebuild the class inheritance delegation class\n"
"        set originDelegate [DelegateName $originObject]\n"
"        set targetDelegate [DelegateName $targetObject]\n"
"        if {\n"
"            [info object isa class $originDelegate]\n"
"            && ![info object isa class $targetDelegate]\n"
"        } then {\n"
"            copy $originDelegate $targetDelegate\n"
"            objdefine $targetObject mixin -set \\\n"
"                {*}[lmap c [info object mixin $targetObject] {\n"
"                    if {$c eq $originDelegate} {set targetDelegate} {set c}\n"
"                }]\n"
"        }\n"

"    }\n"
"}\n"
"\n"
"::namespace eval ::oo::define {\n"
"    ::proc 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 [::format \\\n"

"                {wrong # args: should be \"%s name \?args body\?\"} \\\n"
"                [::lindex [::info level 0] 0]]\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"
"\n"
"    ::proc initialise {body} {\n"
"        ::set clsns [::info object namespace [::uplevel 1 self]]\n"
"        ::tailcall apply [::list {} $body $clsns]\n"
"    }\n"
"\n"
"    # Make the initialise command appear with US spelling too\n"

"    ::namespace export initialise\n"
"    ::namespace eval tmp {::namespace import ::oo::define::initialise}\n"

"    ::rename ::oo::define::tmp::initialise initialize\n"
"    ::namespace delete tmp\n"
"    ::namespace export -clear\n"
"}\n"
"\n"
"::oo::define ::oo::Slot {\n"
"    method Get {} {return -code error unimplemented}\n"


"    method Set list {return -code error unimplemented}\n"
"\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"
"\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"
"\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"
"\n"
"::oo::define ::oo::object method <cloned> {originObject} {\n"
"    # 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"
"            if {[info default $p $a d]} {\n"
"                lset args [incr idx] [list $a $d]\n"
"            } else {\n"
"                lset args [incr idx] [list $a]\n"
"            }\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"
"    # General commands, sub-namespaces and advancd variable config (traces,\n"
"    # etc) are *not* copied over. Classes that want that should do it\n"
"    # themselves.\n"
"}\n"
"\n"
"::oo::define ::oo::class method <cloned> {originObject} {\n"
"    next $originObject\n"
"    # Rebuild the class inheritance delegation class\n"
"    ::oo::UpdateClassDelegatesAfterClone $originObject [self]\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"
"\n"
"::oo::class create ::oo::abstract {\n"
"    superclass ::oo::class\n"
"    unexport create createWithNamespace new\n"

"}\n"
/* !END!: Do not edit above this line. */
;
 
#endif /* TCL_OO_SCRIPT_H */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|
|
|
>
|
|
|
<
|
|
|
|
>
|
<
|
<
|
|
<
<
|
<
<
>
>
>
|
<
|
<
<
>
>
>
|
<
<
>
|
|
<
|
|
|
|
|
<
>
|
|
<
>
>
>
>
|
|
<
>
|
|
|
<
>
|
|
|
<
<
|
|
|
|
|
<
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
<
|
<
|
|
|
|
|
|
|
|
|
|
<
<
>
|
|
<
<
|
<
|
|
<
>
|
|
|
|
|
|
|
<
|
|
<
|
|
|
|
<
<
>
|
|
>
|
|
<
|
<
|
|
>
>
|
<
>
>
|
|
|
|
|
|
|
<
|
|
|
|
|
|
<
>
|
|
<
|
|
|
<
|
|
|
<
|
<
|
|
|
|
|
|
|
|
<
<
>
>
|
|
|
|
<
|
|
|
|
|
|
|
|
<
<
>
|
<
<
<
|
|
|
|
<
|
|
<
|
|
|
|
|
|
|
|
>
>
|
<
>
|
>
|
<
<
>
>
>
|
|
|
<
|
|
|
>













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
 
/*
 * The scripted part of the definitions of TclOO.
 */

static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */
"::namespace eval ::oo {\n"
"\t::namespace path {}\n"
"\tnamespace eval Helpers {\n"
"\t\t::namespace path {}\n"
"\t\tproc callback {method args} {\n"
"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
"\t\t}\n"

"\t\tnamespace export callback\n"
"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
"\t\tnamespace export -clear\n"
"\t\trename tmp::callback mymethod\n"
"\t\tnamespace delete tmp\n"
"\t\tproc classvariable {name args} {\n"

"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"

"\t\t\tforeach v [list $name {*}$args] {\n"
"\t\t\t\tif {[string match *(*) $v]} {\n"


"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"


"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
"\t\t\t\t}\n"
"\t\t\t\tif {[string match *::* $v]} {\n"

"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"


"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
"\t\t\t\t}\n"
"\t\t\t\tlappend vs $v $v\n"


"\t\t\t}\n"
"\t\t\ttailcall namespace upvar $ns {*}$vs\n"
"\t\t}\n"

"\t\tproc link {args} {\n"
"\t\t\tset ns [uplevel 1 {::namespace current}]\n"
"\t\t\tforeach link $args {\n"
"\t\t\t\tif {[llength $link] == 2} {\n"
"\t\t\t\t\tlassign $link src dst\n"

"\t\t\t\t} elseif {[llength $link] == 1} {\n"
"\t\t\t\t\tlassign $link src\n"
"\t\t\t\t\tset dst $src\n"

"\t\t\t\t} else {\n"
"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n"
"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {![string match ::* $src]} {\n"
"\t\t\t\t\tset src [string cat $ns :: $src]\n"

"\t\t\t\t}\n"
"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"

"\t\t\t}\n"
"\t\t\treturn\n"
"\t\t}\n"
"\t}\n"


"\tproc UnlinkLinkedCommand {cmd args} {\n"
"\t\tif {[namespace which $cmd] ne {}} {\n"
"\t\t\trename $cmd {}\n"
"\t\t}\n"
"\t}\n"

"\tproc DelegateName {class} {\n"
"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
"\t}\n"

"\tproc MixinClassDelegates {class} {\n"
"\t\tif {![info object isa class $class]} {\n"
"\t\t\treturn\n"
"\t\t}\n"
"\t\tset delegate [DelegateName $class]\n"
"\t\tif {![info object isa class $delegate]} {\n"
"\t\t\treturn\n"
"\t\t}\n"
"\t\tforeach c [info class superclass $class] {\n"
"\t\t\tset d [DelegateName $c]\n"
"\t\t\tif {![info object isa class $d]} {\n"
"\t\t\t\tcontinue\n"

"\t\t\t}\n"
"\t\t\tdefine $delegate superclass -append $d\n"
"\t\t}\n"
"\t\tobjdefine $class mixin -append $delegate\n"
"\t}\n"

"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"

"\t\tset originDelegate [DelegateName $originObject]\n"
"\t\tset targetDelegate [DelegateName $targetObject]\n"
"\t\tif {\n"
"\t\t\t[info object isa class $originDelegate]\n"
"\t\t\t&& ![info object isa class $targetDelegate]\n"
"\t\t} then {\n"
"\t\t\tcopy $originDelegate $targetDelegate\n"
"\t\t\tobjdefine $targetObject mixin -set \\\n"
"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"


"\t\t\t\t}]\n"
"\t\t}\n"
"\t}\n"


"\tproc define::classmethod {name {args {}} {body {}}} {\n"

"\t\t::set argc [::llength [::info level 0]]\n"
"\t\t::if {$argc == 3} {\n"

"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
"\t\t\t\t[::lindex [::info level 0] 0]]\n"
"\t\t}\n"
"\t\t::set cls [::uplevel 1 self]\n"
"\t\t::if {$argc == 4} {\n"
"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
"\t\t}\n"

"\t\t::tailcall forward $name myclass $name\n"
"\t}\n"

"\tproc define::initialise {body} {\n"
"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
"\t\t::tailcall apply [::list {} $body $clsns]\n"
"\t}\n"


"\tnamespace eval define {\n"
"\t\t::namespace export initialise\n"
"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
"\t\t::namespace export -clear\n"
"\t\t::rename tmp::initialise initialize\n"
"\t\t::namespace delete tmp\n"

"\t}\n"

"\tdefine Slot {\n"
"\t\tmethod Get {} {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Set list {\n"

"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod -set args {tailcall my Set $args}\n"
"\t\tmethod -append args {\n"
"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"
"\t\tmethod -clear {} {tailcall my Set {}}\n"
"\t\tforward --default-operation my -append\n"

"\t\tmethod unknown {args} {\n"
"\t\t\tset def --default-operation\n"
"\t\t\tif {[llength $args] == 0} {\n"
"\t\t\t\ttailcall my $def\n"
"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
"\t\t\t\ttailcall my $def {*}$args\n"

"\t\t\t}\n"
"\t\t\tnext {*}$args\n"
"\t\t}\n"

"\t\texport -set -append -clear\n"
"\t\tunexport unknown destroy\n"
"\t}\n"

"\tobjdefine define::superclass forward --default-operation my -set\n"
"\tobjdefine define::mixin forward --default-operation my -set\n"
"\tobjdefine objdefine::mixin forward --default-operation my -set\n"

"\tdefine object method <cloned> {originObject} {\n"

"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
"\t\t\tset args [info args $p]\n"
"\t\t\tset idx -1\n"
"\t\t\tforeach a $args {\n"
"\t\t\t\tif {[info default $p $a d]} {\n"
"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\tlset args [incr idx] [list $a]\n"


"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\tset b [info body $p]\n"
"\t\t\tset p [namespace tail $p]\n"
"\t\t\tproc $p $args $b\n"
"\t\t}\n"

"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n"
"\t\t\tupvar 0 $v vOrigin\n"
"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
"\t\t\tif {[info exists vOrigin]} {\n"
"\t\t\t\tif {[array exists vOrigin]} {\n"
"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\tset vNew $vOrigin\n"


"\t\t\t\t}\n"
"\t\t\t}\n"



"\t\t}\n"
"\t}\n"
"\tdefine class method <cloned> {originObject} {\n"
"\t\tnext $originObject\n"

"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
"\t}\n"

"\tclass create singleton {\n"
"\t\tsuperclass class\n"
"\t\tvariable object\n"
"\t\tunexport create createWithNamespace\n"
"\t\tmethod new args {\n"
"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
"\t\t\t\tset object [next {*}$args]\n"
"\t\t\t\t::oo::objdefine $object {\n"
"\t\t\t\t\tmethod destroy {} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"

"\t\t\t\t\t}\n"
"\t\t\t\t\tmethod <cloned> {originObject} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"


"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn $object\n"
"\t\t}\n"
"\t}\n"

"\tclass create abstract {\n"
"\t\tsuperclass class\n"
"\t\tunexport create createWithNamespace new\n"
"\t}\n"
"}\n"
/* !END!: Do not edit above this line. */
;
 
#endif /* TCL_OO_SCRIPT_H */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclOOScript.tcl.

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
..
89
90
91
92
93
94
95









96
97
98
99
100
101
102
...
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
# 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]} {
................................................................................
		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]
................................................................................
	    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:







|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|

<
<
>
>
>
>
>
>
|
>
|
>
>
>
>
>
>
|
|
|
|
|
|
<
>
|
|
<
|
|
>
|
|
<
|
|
|
|
|
|

>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
<
>
|
|
>
>
>
|
|
|
|
|
|
|
|
|
|
|

<
>
>
>
>
>
>
>
>
>






>
>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>







 







|
>
|
<
>
>
>
>
>
>
>
>
>
>
|



|











>
>
>
>
>
>
>
>
>
>
>
>
|




<
>
>
|
|
>
|
|
<
|

>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
<

>
>
|
|
|
|
|
|
|
|
|

>
|
|
|

>
|
|
|

>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

>
>
>
>
>
>
>
>
|
|
|
|
|

>
>
|
>
>
>
>
>
>
>
|
|
|
|
|
|
|
>
>
|
|
|
>
|
|
|
>
|
|
|

>
>
|
>
>
>
>
>
>
>
|
|
|
>






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
...
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
...
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
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291

292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
# 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 {
    ::namespace path {}

    #
    # Commands that are made available to objects by default.
    #
    namespace eval Helpers {
	::namespace path {}

	# ------------------------------------------------------------------
	#
	# callback, mymethod --
	#
	#	Create a script prefix that calls a method on the current
	#	object. Same operation, two names.
	#
	# ------------------------------------------------------------------

	proc callback {method args} {
	    list [uplevel 1 {::namespace which my}] $method {*}$args
	}



	# Make the [callback] command appear as [mymethod] too.
	namespace export callback
	namespace eval tmp {namespace import ::oo::Helpers::callback}
	namespace export -clear
	rename tmp::callback mymethod
	namespace delete tmp

	# ------------------------------------------------------------------
	#
	# classvariable --
	#
	#	Link to a variable in the class of the current object.
	#
	# ------------------------------------------------------------------

	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]} {

		    set reason "can't create a scalar variable that looks like an array element"
		    return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
			[format {bad variable name "%s": %s} $v $reason]

		}
		if {[string match *::* $v]} {
		    set reason "can't create a local variable with a namespace separator in it"
		    return -code error -errorcode {TCL UPVAR INVERTED} \
			[format {bad variable name "%s": %s} $v $reason]

		}
		lappend vs $v $v
	    }
	    # Lastly, link the caller's local variables to the class's variables
	    tailcall namespace upvar $ns {*}$vs
	}

	# ------------------------------------------------------------------
	#
	# link --
	#
	#	Make a command that invokes a method on the current object.
	#	The name of the command and the name of the method match by
	#	default.
	#
	# ------------------------------------------------------------------

	proc link {args} {
	    set ns [uplevel 1 {::namespace current}]
	    foreach link $args {
		if {[llength $link] == 2} {
		    lassign $link src dst

		} elseif {[llength $link] == 1} {
		    lassign $link src
		    set dst $src
		} else {
		    return -code error -errorcode {TCLOO CMDLINK FORMAT} \
			"bad link description; must only have one or two elements"
		}
		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
	}
    }


    # ----------------------------------------------------------------------
    #
    # UnlinkLinkedCommand --
    #
    #	Callback used to remove linked command when the underlying mechanism
    #	that supports it is deleted.
    #
    # ----------------------------------------------------------------------

    proc UnlinkLinkedCommand {cmd args} {
	if {[namespace which $cmd] ne {}} {
	    rename $cmd {}
	}
    }

    # ----------------------------------------------------------------------
    #
    # DelegateName --
    #
    #	Utility that gets the name of the class delegate for a class. It's
    #	trivial, but makes working with them much easier as delegate names are
    #	intentionally hard to create by accident.
    #
    # ----------------------------------------------------------------------

    proc DelegateName {class} {
	string cat [info object namespace $class] {:: oo ::delegate}
    }

    # ----------------------------------------------------------------------
    #
    # MixinClassDelegates --
    #
    #	Support code called *after* [oo::define] inside the constructor of a
    #	class that patches in the appropriate class delegates.
    #
    # ----------------------------------------------------------------------

    proc MixinClassDelegates {class} {
	if {![info object isa class $class]} {
	    return
	}
	set delegate [DelegateName $class]
	if {![info object isa class $delegate]} {
................................................................................
		continue
	    }
	    define $delegate superclass -append $d
	}
	objdefine $class mixin -append $delegate
    }

    # ----------------------------------------------------------------------
    #
    # UpdateClassDelegatesAfterClone --
    #
    #	Support code that is like [MixinClassDelegates] except for when a
    #	class is cloned.
    #
    # ----------------------------------------------------------------------

    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]
................................................................................
	    copy $originDelegate $targetDelegate
	    objdefine $targetObject mixin -set \
		{*}[lmap c [info object mixin $targetObject] {
		    if {$c eq $originDelegate} {set targetDelegate} {set c}
		}]
	}
    }

    # ----------------------------------------------------------------------
    #

    # oo::define::classmethod --
    #
    #	Defines a class method. See define(n) for details.
    #
    # Note that the ::oo::define namespace is semi-public and a bit weird
    # anyway, so we don't regard the namespace path as being under control:
    # fully qualified names are used for everything.
    #
    # ----------------------------------------------------------------------

    proc define::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 -errorcode {TCL WRONGARGS} [::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
    }

    # ----------------------------------------------------------------------
    #
    # oo::define::initialise, oo::define::initialize --
    #
    #	Do specific initialisation for a class. See define(n) for details.
    #
    # Note that the ::oo::define namespace is semi-public and a bit weird
    # anyway, so we don't regard the namespace path as being under control:
    # fully qualified names are used for everything.
    #
    # ----------------------------------------------------------------------

    proc define::initialise {body} {
        ::set clsns [::info object namespace [::uplevel 1 self]]
        ::tailcall apply [::list {} $body $clsns]
    }


    # Make the [initialise] definition appear as [initialize] too
    namespace eval define {
	::namespace export initialise
	::namespace eval tmp {::namespace import ::oo::define::initialise}
	::namespace export -clear
	::rename tmp::initialise initialize
	::namespace delete tmp

    }

    # ----------------------------------------------------------------------
    #
    # Slot --
    #
    #	The class of slot operations, which are basically lists at the low
    #	level of TclOO; this provides a more consistent interface to them.
    #
    # ----------------------------------------------------------------------

    define Slot {
	# ------------------------------------------------------------------
	#
	# Slot Get --
	#
	#	Basic slot getter. Retrieves the contents of the slot.
	#	Particular slots must provide concrete non-erroring
	#	implementation.
	#
	# ------------------------------------------------------------------

	method Get {} {
	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
	}

	# ------------------------------------------------------------------
	#
	# Slot Set --
	#
	#	Basic slot setter. Sets the contents of the slot.  Particular
	#	slots must provide concrete non-erroring implementation.
	#
	# ------------------------------------------------------------------

	method Set list {
	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
	}

	# ------------------------------------------------------------------
	#
	# Slot -set, -append, -clear, --default-operation --
	#
	#	Standard public slot operations. If a slot can't figure out
	#	what method to call directly, it uses --default-operation.
	#
	# ------------------------------------------------------------------

	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 {}}


	# Default handling
	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
	}

	# Set up what is exported and what isn't
	export -set -append -clear
	unexport unknown destroy
    }

    # Set the default operation differently for these slots
    objdefine define::superclass forward --default-operation my -set
    objdefine define::mixin forward --default-operation my -set
    objdefine objdefine::mixin forward --default-operation my -set

    # ----------------------------------------------------------------------
    #
    # oo::object <cloned> --
    #
    #	Handler for cloning objects that clones basic bits (only!) of the
    #	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
    #	more complex (and class-specific) handling.
    #
    # ----------------------------------------------------------------------

    define 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::class <cloned> --
    #
    #	Handler for cloning classes, which fixes up the delegates.
    #
    # ----------------------------------------------------------------------

    define class method <cloned> {originObject} {
	next $originObject
	# Rebuild the class inheritance delegation class
	::oo::UpdateClassDelegatesAfterClone $originObject [self]
    }

    # ----------------------------------------------------------------------
    #
    # oo::singleton --
    #
    #	A metaclass that is used to make classes that only permit one instance
    #	of them to exist. See singleton(n).
    #
    # ----------------------------------------------------------------------

    class create singleton {
	superclass 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 -errorcode {TCLOO SINGLETON} \
			    "may not destroy a singleton object"
		    }
		    method <cloned> {originObject} {
			::return -code error -errorcode {TCLOO SINGLETON} \
			    "may not clone a singleton object"
		    }
		}
	    }
	    return $object
	}
    }

    # ----------------------------------------------------------------------
    #
    # oo::abstract --
    #
    #	A metaclass that is used to make classes that can't be directly
    #	instantiated. See abstract(n).
    #
    # ----------------------------------------------------------------------

    class create abstract {
	superclass class
	unexport create createWithNamespace new
    }
}
 
# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End:

Changes to tests/ooUtil.test.

134
135
136
137
138
139
140







































141
142
143
144
145
146
147
            puts "This is meee 2"
        }
    }
    list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar]
} -cleanup {
    parent destroy
} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"








































test ooUtil-2.1 {TIP 478: callback generation} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method CallMe {} { return ok,[self] }







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
            puts "This is meee 2"
        }
    }
    list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar]
} -cleanup {
    parent destroy
} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"
# Two tests to confirm that we correctly initialise the scripted part of TclOO
# in child interpreters. This is slightly tricky at the implementation level
# because we cannot count on either [source] or [open] being available.
test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup {
    set childinterp [interp create]
} -body {
    $childinterp eval {
	oo::class create ActiveRecord {
	    classmethod find args {
		return "[self] called with arguments: $args"
	    }
	}
	oo::class create Table {
	    superclass ActiveRecord
	}
	# This is confirming that this is not the master interpreter
	list [Table find foo bar] [info globals childinterp]
    }
} -cleanup {
    interp delete $childinterp
} -result {{::Table called with arguments: foo bar} {}}
test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup {
    set safeinterp [interp create -safe]
} -body {
    $safeinterp eval {
	oo::class create ActiveRecord {
	    classmethod find args {
		return "[self] called with arguments: $args"
	    }
	}
	oo::class create Table {
	    superclass ActiveRecord
	}
	# This is confirming that this is a (basic) safe interpreter
	list [Table find foo bar] [info commands source]
    }
} -cleanup {
    interp delete $safeinterp
} -result {{::Table called with arguments: foo bar} {}}

test ooUtil-2.1 {TIP 478: callback generation} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method CallMe {} { return ok,[self] }

Changes to tools/makeHeader.tcl.

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
    # mapSpecial --
    #	Transform a single line so that it is able to be put in a C string.
    #
    proc mapSpecial {str} {
	# All Tcl metacharacters and key C backslash sequences
	set MAP {
	    \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
	    \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t {        } \v \\\\v
	}
	set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}

	subst [regsub -all {[^\u0020-\u007e]} [string map $MAP $str] $XFORM]
    }
















    ####################################################################
    #
    # processScript --
    #	Transform a whole sequence of lines with [mapSpecial].
    #
    proc processScript {scriptLines} {
	lmap line $scriptLines {



	    format {"%s"} [mapSpecial $line\n]
	}
    }

    ####################################################################
    #
    # updateTemplate --
    #	Rewrite a template to contain the content from the input script.







|





>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








>
>
>
|







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
    # mapSpecial --
    #	Transform a single line so that it is able to be put in a C string.
    #
    proc mapSpecial {str} {
	# All Tcl metacharacters and key C backslash sequences
	set MAP {
	    \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
	    \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
	}
	set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}

	subst [regsub -all {[^\u0020-\u007e]} [string map $MAP $str] $XFORM]
    }

    ####################################################################
    #
    # compactLeadingSpaces --
    #	Converts the leading whitespace on a line into a more compact form.
    #
    proc compactLeadingSpaces {line} {
	set line [string map {\t {        }} [string trimright $line]]
	if {[regexp {^[ ]+} $line spaces]} {
	    regsub -all {[ ]{4}} $spaces \t replace
	    set len [expr {[string length $spaces] - 1}]
	    set line [string replace $line 0 $len $replace]
	}
	return $line
    }

    ####################################################################
    #
    # processScript --
    #	Transform a whole sequence of lines with [mapSpecial].
    #
    proc processScript {scriptLines} {
	lmap line $scriptLines {
	    # Skip blank and comment lines; they're there in the original
	    # sources so we don't need to copy them over.
	    if {[regexp {^\s*(?:#|$)} $line]} continue
	    format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n]
	}
    }

    ####################################################################
    #
    # updateTemplate --
    #	Rewrite a template to contain the content from the input script.