Tcl Source Code

Check-in [c919d1df55]
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:Most of the implementation ported over. [classmethod] is trickier...
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256: c919d1df552bca40f3f685fb4e16452c2ce3d3255bb80f59dbae9e93b3ae28e5
User & Date: dkf 2018-06-17 16:47:45
Context
2018-06-17
17:27
Leaving out the weird delegates stops the test failures. check-in: faf87d4008 user: dkf tags: tip-478
16:47
Most of the implementation ported over. [classmethod] is trickier... check-in: c919d1df55 user: dkf tags: tip-478
15:42
Split scripted parts of TclOO into their own file. check-in: f1433a4120 user: dkf tags: tip-478
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOOScript.h.

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

static const char *tclOOSetupScript =
















































































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























/*
 * The body of the <cloned> method of oo::object.
 */

static const char *clonedBody =
"foreach p [info procs [info object namespace $originObject]::*] {\n"






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



>







>









>






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







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
#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::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"
"    # Get the name of the current class or class delegate\n"
"    set cls [uplevel 1 self]\n"
"    set d $cls.Delegate\n"
"    if {[info object isa object $d] && [info object isa class $d]} {\n"
"        set cls $d\n"
"    }\n"
"    if {$argc == 4} {\n"
"        ::oo::define $cls method $name $args $body\n"
"    }\n"
"    # Make the connection by forwarding\n"
"    tailcall forward $name [info object namespace $cls]::my $name\n"
"}\n"

"# Build this *almost* like a class method, but with extra care to avoid\n"
"# nuking the existing method.\n"
"::oo::class create ::oo::class.Delegate {\n"
"    method create {name args} {\n"
"        if {![string match ::* $name]} {\n"
"            set ns [uplevel 1 {namespace current}]\n"
"            if {$ns eq {::}} {set ns {}}\n"
"            set name ${ns}::${name}\n"
"        }\n"
"        if {[string match *.Delegate $name]} {\n"
"            return [next $name {*}$args]\n"
"        }\n"
"        set delegate [oo::class create $name.Delegate]\n"
"        set cls [next $name {*}$args]\n"
"        set superdelegates [list $delegate]\n"
"        foreach c [info class superclass $cls] {\n"
"            set d $c.Delegate\n"
"            if {[info object isa object $d] && [info object isa class $d]} {\n"
"                lappend superdelegates $d\n"
"            }\n"
"        }\n"
"        oo::objdefine $cls mixin {*}$superdelegates\n"
"        return $cls\n"
"    }\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 self mixin ::oo::class.Delegate\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 =
"foreach p [info procs [info object namespace $originObject]::*] {\n"

Changes to tests/oo.test.

339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
	foreach initial {object class Slot} {
	    lappend x [info object class ::oo::$initial]
	}
	return $x
    }] {lsort $x}
} -cleanup {
    interp delete $fresh
} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}

test oo-2.1 {basic test of OO functionality: constructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
    interp create subinterp
    subinterp eval {
	package require TclOO






|







339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
	foreach initial {object class Slot} {
	    lappend x [info object class ::oo::$initial]
	}
	return $x
    }] {lsort $x}
} -cleanup {
    interp delete $fresh
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}

test oo-2.1 {basic test of OO functionality: constructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
    interp create subinterp
    subinterp eval {
	package require TclOO