Tcl Source Code

Check-in [e9637e3ddc]
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:Add better error handling and make the delegation work with cloning.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256: e9637e3ddcf317376a9cd10a8fc45d4a88976eb85360563f6db929bed877f986
User & Date: dkf 2018-06-27 07:39:49
Context
2018-06-28
08:12
Tests for abstract and singleton check-in: 6893bec0d9 user: dkf tags: tip-478
2018-06-27
07:39
Add better error handling and make the delegation work with cloning. check-in: e9637e3ddc user: dkf tags: tip-478
2018-06-23
15:03
Make the delegates work by moving their creation into C. check-in: b3c558369f user: dkf tags: tip-478
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOOBasic.c.

118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
...
135
136
137
138
139
140
141

142

143
144

145
146

147

148
149

150
151




152
153
154
155
156
157
158
     * trouble.
     */

    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    Tcl_IncrRefCount(invoke[2]);
    TclNRAddCallback(interp, DecrRefsPostClassConstructor,
	    invoke, NULL, NULL, NULL);

    /*
     * Tricky point: do not want the extra reported level in the Tcl stack
     * trace, so use TCL_EVAL_NOERR.
     */

    return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
................................................................................
static int
DecrRefsPostClassConstructor(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **invoke = data[0];

    Tcl_InterpState saved;


    TclDecrRefCount(invoke[0]);

    TclDecrRefCount(invoke[2]);
    invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);

    Tcl_IncrRefCount(invoke[0]);

    saved = Tcl_SaveInterpState(interp, result);
    Tcl_EvalObjv(interp, 2, invoke, 0);

    TclDecrRefCount(invoke[1]);
    ckfree(invoke);




    return Tcl_RestoreInterpState(interp, saved);
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --






|







 







>

>


>


>

>

|
>


>
>
>
>







118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
...
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
     * trouble.
     */

    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    Tcl_IncrRefCount(invoke[2]);
    TclNRAddCallback(interp, DecrRefsPostClassConstructor,
	    invoke, oPtr, NULL, NULL);

    /*
     * Tricky point: do not want the extra reported level in the Tcl stack
     * trace, so use TCL_EVAL_NOERR.
     */

    return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
................................................................................
static int
DecrRefsPostClassConstructor(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **invoke = data[0];
    Object *oPtr = data[1];
    Tcl_InterpState saved;
    int code;

    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    TclDecrRefCount(invoke[2]);
    invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
    invoke[1] = TclOOObjectName(interp, oPtr);
    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    saved = Tcl_SaveInterpState(interp, result);
    code = Tcl_EvalObjv(interp, 2, invoke, 0);
    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    ckfree(invoke);
    if (code != TCL_OK) {
	Tcl_DiscardInterpState(saved);
	return code;
    }
    return Tcl_RestoreInterpState(interp, saved);
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --

Changes to generic/tclOOScript.h.

69
70
71
72
73
74
75







76
77
78



79

80
81
82
83
84
85
86
...
109
110
111
112
113
114
115













116
117
118
119
120
121
122
...
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
"        ::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
"    }\n"
"    # Make the connection by forwarding\n"
"    tailcall forward $name [info object namespace $cls]::my $name\n"
"}\n"

"proc ::oo::MixinClassDelegates {class} {\n"







"    ::oo::objdefine $class mixin -append {*}[lmap c [info class superclass $class] {\n"
"        set d [::oo::DelegateName $c]\n"
"        if {![info object isa class $d]} continue; set d\n"



"    }]\n"

"}\n"

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

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

static const char *clonedBody =

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

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






>
>
>
>
>
>
>
|

|
>
>
>
|
>







 







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







 







>











>










|
>










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
...
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
...
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
"        ::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
"    }\n"
"    # Make the connection by forwarding\n"
"    tailcall forward $name [info object namespace $cls]::my $name\n"
"}\n"

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

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

................................................................................
"    export -set -append -clear\n"
"    unexport unknown destroy\n"
"}\n"
"\n"
"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"

"::oo::define ::oo::class method <cloned> {originObject} {\n"
"    next $originObject\n"
"    # Rebuild the class inheritance delegation class\n"
"    set originDelegate [::oo::DelegateName $originObject]\n"
"    set targetDelegate [::oo::DelegateName [self]]\n"
"    if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {\n"
"        ::oo::copy $originDelegate $targetDelegate\n"
"        ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {\n"
"            if {$c eq $originDelegate} {set targetDelegate} {set c}\n"
"        }]\n"
"    }\n"
"}\n"

"::oo::class create ::oo::singleton {\n"
"    superclass ::oo::class\n"
"    variable object\n"
"    unexport create createWithNamespace\n"
"    method new args {\n"
"        if {![info exists object]} {\n"
................................................................................
;

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

Changes to tests/oo.test.

4847
4848
4849
4850
4851
4852
4853

4854

4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867

4868

4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890







4891
























































































































4892
4893
4894
4895
4896
4897
} -result {{} {} foo {} foo {}}

test oo-41.1 {TIP 478: classmethod} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {
	superclass parent

        classmethod find args { puts "[self] called with arguments: $args" }

    }
    oo::class create Table {
        superclass ActiveRecord
    }
    Table find foo bar
} -cleanup {
    parent destroy
} -output "::Table called with arguments: foo bar\n"
test oo-41.2 {TIP 478: classmethod in namespace} -setup {
    namespace eval ::testns {}
} -body {
    namespace eval ::testns {
	oo::class create ActiveRecord {

	    classmethod find args { puts "[self] called with arguments: $args" }

	}
	oo::class create Table {
	    superclass ActiveRecord
	}
    }
    testns::Table find foo bar
} -cleanup {
    namespace delete ::testns
} -output "::testns::Table called with arguments: foo bar\n"
test oo-41.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup {
    oo::class create parent
} -body {
    oo::class create TestClass {
        superclass oo::class parent
        self method create {name ignore body} {
            next $name $body
        }
    }
    TestClass create okay {} {}
} -cleanup {
    parent destroy
} -result {::okay}







 
























































































































cleanupTests
return

# Local Variables:
# mode: tcl
# End:






>
|
>







|





>
|
>








|













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






4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
} -result {{} {} foo {} foo {}}

test oo-41.1 {TIP 478: classmethod} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {
	superclass parent
        classmethod find args {
	    return "[self] called with arguments: $args"
	}
    }
    oo::class create Table {
        superclass ActiveRecord
    }
    Table find foo bar
} -cleanup {
    parent destroy
} -result {::Table called with arguments: foo bar}
test oo-41.2 {TIP 478: classmethod in namespace} -setup {
    namespace eval ::testns {}
} -body {
    namespace eval ::testns {
	oo::class create ActiveRecord {
	    classmethod find args {
		return "[self] called with arguments: $args"
	    }
	}
	oo::class create Table {
	    superclass ActiveRecord
	}
    }
    testns::Table find foo bar
} -cleanup {
    namespace delete ::testns
} -result {::testns::Table called with arguments: foo bar}
test oo-41.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup {
    oo::class create parent
} -body {
    oo::class create TestClass {
        superclass oo::class parent
        self method create {name ignore body} {
            next $name $body
        }
    }
    TestClass create okay {} {}
} -cleanup {
    parent destroy
} -result {::okay}
test oo-41.4 {TIP 478: classmethod with three levels} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {
	superclass parent
        classmethod find args {
	    return "[self] called with arguments: $args"
	}
    }
    oo::class create Table {
        superclass ActiveRecord
    }
    oo::class create SubTable {
        superclass Table
    }
    SubTable find foo bar
} -cleanup {
    parent destroy
} -result {::SubTable called with arguments: foo bar}

test oo-42.1 {TIP 478: callback generation} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method CallMe {} { return ok,[self] }
	method makeCall {} {
	    return [callback CallMe]
	}
    }
    c create ::context
    set cb [context makeCall]
    {*}$cb
} -cleanup {
    parent destroy
} -result {ok,::context}
test oo-42.2 {TIP 478: callback generation} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method CallMe {a b c} { return ok,[self],$a,$b,$c }
	method makeCall {b} {
	    return [callback CallMe 123 $b]
	}
    }
    c create ::context
    set cb [context makeCall "a b c"]
    {*}$cb PQR
} -cleanup {
    parent destroy
} -result {ok,::context,123,a b c,PQR}
test oo-42.3 {TIP 478: callback generation, alternate name} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method CallMe {} { return ok,[self] }
	method makeCall {} {
	    return [mymethod CallMe]
	}
    }
    c create ::context
    set cb [context makeCall]
    {*}$cb
} -cleanup {
    parent destroy
} -result {ok,::context}
test oo-42.4 {TIP 478: callback generation, alternate name} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method CallMe {a b c} { return ok,[self],$a,$b,$c }
	method makeCall {b} {
	    return [mymethod CallMe 123 $b]
	}
    }
    c create ::context
    set cb [context makeCall "a b c"]
    {*}$cb PQR
} -cleanup {
    parent destroy
} -result {ok,::context,123,a b c,PQR}
test oo-42.5 {TIP 478: callbacks and method lifetime} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method makeCall {b} {
	    return [callback CallMe 123 $b]
	}
    }
    c create ::context
    set cb [context makeCall "a b c"]
    set result [list [catch {{*}$cb PQR} msg] $msg]
    oo::objdefine context {
	method CallMe {a b c} { return ok,[self],$a,$b,$c }
    }
    lappend result [{*}$cb PQR]
} -cleanup {
    parent destroy
} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}}
test oo-42.6 {TIP 478: callback use case} -setup {
    oo::class create parent
    unset -nocomplain x
} -body {
    oo::class create c {
	superclass parent
	variable count
	constructor {var} {
	    set count 0
	    upvar 1 $var v
	    trace add variable v write [callback TraceCallback]
	}
	method count {} {return $count}
	method TraceCallback {name1 name2 op} {
	    incr count
	}
    }
    set o [c new x]
    for {set x 0} {$x < 5} {incr x} {}
    $o count
} -cleanup {
    unset -nocomplain x
    parent destroy
} -result 6
 
cleanupTests
return

# Local Variables:
# mode: tcl
# End: