Tcl Source Code

Check-in [155bc7ab0b]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:Added more tests and made [initialize] an alternate spelling for [initialise].
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256: 155bc7ab0b79deb7b3a133c5697a945bff80d04d8d2d8cbc055d7ba0b99d87dd
User & Date: dkf 2018-07-15 15:46:33
Context
2018-08-05
15:01
Make it much easier to maintain the TclOO initialisation script. check-in: a769968834 user: dkf tags: tip-478
2018-07-15
15:46
Added more tests and made [initialize] an alternate spelling for [initialise]. check-in: 155bc7ab0b user: dkf tags: tip-478
2018-07-07
08:57
And another test check-in: 129070ddc7 user: dkf tags: tip-478
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to doc/define.n.

128
129
130
131
132
133
134


135
136
137
138
139
140
141
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
below), this command creates private forwarded methods.
.VE TIP500
.RE
.TP
\fBinitialise\fI script\fR


.VS TIP478
This evaluates \fIscript\fR in a context which supports local variables and
where the current namespace is the instance namespace of the class object
itself. This is useful for setting up, e.g., class-scoped variables.
.VE TIP478
.TP
\fBmethod\fI name argList bodyScript\fR






>
>







128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
below), this command creates private forwarded methods.
.VE TIP500
.RE
.TP
\fBinitialise\fI script\fR
.TP
\fBinitialize\fI script\fR
.VS TIP478
This evaluates \fIscript\fR in a context which supports local variables and
where the current namespace is the instance namespace of the class object
itself. This is useful for setting up, e.g., class-scoped variables.
.VE TIP478
.TP
\fBmethod\fI name argList bodyScript\fR

Changes to generic/tclOOScript.h.

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
...
102
103
104
105
106
107
108
















109
110
111








112
113
114
115
116
117
118
"    }\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"
................................................................................
"            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"






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







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







69
70
71
72
73
74
75















76
77
78
79
80
81
82
..
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
"    }\n"
"}\n"

"::proc ::oo::DelegateName {class} {\n"
"    string cat [info object namespace $class] {:: oo ::delegate}\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"
................................................................................
"            continue\n"
"        }\n"
"        ::oo::define $delegate superclass -append $d\n"
"    }\n"
"    ::oo::objdefine $class mixin -append $delegate\n"
"}\n"

"::namespace eval ::oo::define {"
"    ::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 [::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 initialise {body} {\n"
"        ::set clsns [::info object namespace [::uplevel 1 self]]\n"
"        ::tailcall apply [::list {} $body $clsns]\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"

"::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"

Changes to tests/ooUtil.test.

282
283
284
285
286
287
288













































289
290
291
292
293
294
295
    cls create a
    cls create b
    cls create c
    list [a call] [b call] [c call] [a call] [b call] [c call]
} -cleanup {
    parent destroy
} -result {124 125 126 127 128 129}














































test ooUtil-4.1 {TIP 478: singleton} -setup {
    oo::class create parent
} -body {
    oo::singleton create xyz {
	superclass parent
    }






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







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
    cls create a
    cls create b
    cls create c
    list [a call] [b call] [c call] [a call] [b call] [c call]
} -cleanup {
    parent destroy
} -result {124 125 126 127 128 129}
test ooUtil-3.3 {TIP 478: class initialisation} -setup {
    oo::class create parent
    catch {rename ::foobar-3.3 {}}
} -body {
    oo::class create ::cls {
	superclass parent
	initialize {
	    proc foobar-3.3 {} {return ok}
	}
	method calls {} {
	    list [catch foobar-3.3 msg] $msg \
		[namespace eval [info object namespace [self class]] foobar-3.3]
	}
    }
    [cls new] calls
} -cleanup {
    parent destroy
} -result {1 {invalid command name "foobar-3.3"} ok}
test ooUtil-3.4 {TIP 478: class initialisation} -setup {
    oo::class create parent
    catch {rename ::appendToResultVar {}}
    proc ::appendToResultVar args {
	lappend ::result {*}$args
    }
    set result {}
} -body {
    trace add execution oo::define::initialise enter appendToResultVar
    oo::class create ::cls {
	superclass parent
	initialize {proc xyzzy {} {}}
    }
    return $result
} -cleanup {
    catch {
	trace remove execution oo::define::initialise enter appendToResultVar
    }
    rename ::appendToResultVar {}
    parent destroy
} -result {{initialize {proc xyzzy {} {}}} enter}
test ooUtil-3.5 {TIP 478: class initialisation} -body {
    oo::define oo::object {
	::list [::namespace which initialise] [::namespace which initialize] \
	     [::namespace origin initialise] [::namespace origin initialize]
    }
} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise}

test ooUtil-4.1 {TIP 478: singleton} -setup {
    oo::class create parent
} -body {
    oo::singleton create xyz {
	superclass parent
    }