Tcl Source Code

Check-in [af7aa1c82c]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2018 Conference, Houston/TX, US, Oct 15-19
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Aug 20.

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

Overview
Comment:Combine the two bits of scripted code inside TclOO's definition into one.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256:af7aa1c82ce3310b5e8a3f114273d89775057b1b0e7586b387b29d91cb081808
User & Date: dkf 2018-08-05 20:14:04
Context
2018-08-11
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
15:01
Make it much easier to maintain the TclOO initialisation script. check-in: a769968834 user: dkf tags: tip-478
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOO.c.

308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
...
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
InitFoundation(
    Tcl_Interp *interp)
{
    static Tcl_ThreadDataKey tsdKey;
    ThreadLocalData *tsdPtr =
	    Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
    Foundation *fPtr = ckalloc(sizeof(Foundation));
    Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
    Tcl_DString buffer;
    Command *cmdPtr;
    int i;

    /*
     * Initialize the structure that holds the OO system core. This is
     * attached to the interpreter via an assocData entry; not very efficient,
................................................................................
    for (i=0 ; objMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
    }
    for (i=0 ; clsMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
    }

    /*
     * Create the default <cloned> method implementation, used when 'oo::copy'
     * is called to finish the copying of one object to another.
     */

    TclNewLiteralStringObj(argsPtr, "originObject");
    Tcl_IncrRefCount(argsPtr);
    bodyPtr = Tcl_NewStringObj(clonedBody, -1);
    TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
	    bodyPtr, NULL);
    TclDecrRefCount(argsPtr);

    /*
     * Finish setting up the class of classes by marking the 'new' method as
     * private; classes, unlike general objects, must have explicit names. We
     * also need to create the constructor for classes.
     */

    TclNewLiteralStringObj(namePtr, "new");







|







 







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







308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
...
387
388
389
390
391
392
393












394
395
396
397
398
399
400
InitFoundation(
    Tcl_Interp *interp)
{
    static Tcl_ThreadDataKey tsdKey;
    ThreadLocalData *tsdPtr =
	    Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
    Foundation *fPtr = ckalloc(sizeof(Foundation));
    Tcl_Obj *namePtr;
    Tcl_DString buffer;
    Command *cmdPtr;
    int i;

    /*
     * Initialize the structure that holds the OO system core. This is
     * attached to the interpreter via an assocData entry; not very efficient,
................................................................................
    for (i=0 ; objMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
    }
    for (i=0 ; clsMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
    }













    /*
     * Finish setting up the class of classes by marking the 'new' method as
     * private; classes, unlike general objects, must have explicit names. We
     * also need to create the constructor for classes.
     */

    TclNewLiteralStringObj(namePtr, "new");

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

static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */



"::proc ::oo::Helpers::callback {method args} {\n"
"    list [uplevel 1 {namespace which my}] $method {*}$args\n"
"}\n"
"\n"
"::proc ::oo::Helpers::mymethod {method args} {\n"
"    list [uplevel 1 {namespace which my}] $method {*}$args\n"
"}\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"
"\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"
"\n"







"::proc ::oo::DelegateName {class} {\n"
"    string cat [info object namespace $class] {:: oo ::delegate}\n"
"}\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] {\n"
"        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"
"\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 [::string cat {wrong # args: should be \"} \\\n"

"                    [::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"
................................................................................
"    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::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"
"\n"
"::oo::class create ::oo::singleton {\n"
"    superclass ::oo::class\n"
"    variable object\n"
"    unexport create createWithNamespace\n"
"    method new args {\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. */
;

/*
 * 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:
 */







>
>
>
|
|
|

|
|
|

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

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



>
>
>
>
>
>
>
|
|
|

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







|
>
|







 








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

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







 







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










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
...
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
...
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"
................................................................................
"    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"
................................................................................
"\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:
 */

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
84
85
86
87
88
89

90
91
92
93
94
95
96
97
...
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
# 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.
 



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

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

::proc ::oo::Helpers::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]} {


            return -code error [string cat {bad variable name "} $v {": can't create a scalar variable that looks like an array element}]

        }
        if {[string match *::* $v]} {

            return -code error [string cat {bad variable name "} $v {": can't create a local variable with a namespace separator in it}]

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

::proc ::oo::Helpers::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::Helpers::Unlink $src]

    }
    return
}
::proc ::oo::Helpers::Unlink {cmd args} {




    if {[namespace which $cmd] ne {}} {
        rename $cmd {}
    }
}

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

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

















}

::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 [::string cat {wrong # args: should be "} \

                    [::lindex [::info level 0] 0] { name ?args body?"}]
        }
        ::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
................................................................................
    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::class method <cloned> {originObject} {
    next $originObject
    # Rebuild the class inheritance delegation class
    set originDelegate [::oo::DelegateName $originObject]
    set targetDelegate [::oo::DelegateName [self]]
    if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {
        ::oo::copy $originDelegate $targetDelegate
        ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {
            if {$c eq $originDelegate} {set targetDelegate} {set c}
        }]
    }

}

::oo::class create ::oo::singleton {
    superclass ::oo::class
    variable object
    unexport create createWithNamespace
    method new args {







>
>
>
|
|
|

|
|
|

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

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

|
|
|

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







|
>
|







 








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



<
<
<
<
<
<
<
<
>







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
...
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
# 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
................................................................................
    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 {

Changes to tools/makeHeader.tcl.

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
    # 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]
    }

    ####################################################################







|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
    # 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]
    }

    ####################################################################