Tcl Source Code

Changes On Branch tip-567
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Changes In Branch tip-567 Excluding Merge-Ins

This is equivalent to a diff from 7467a34f63 to f4028b1cc3

2021-01-08
10:48
Fix memory leak Leaf check-in: f4028b1cc3 user: jan.nijtmans tags: tip-567
2021-01-05
10:29
Merge 8.6 check-in: 68a7b75991 user: jan.nijtmans tags: core-8-branch
09:27
Merge 8.7 check-in: 43e2fb7b63 user: jan.nijtmans tags: tip-567
09:21
Merge 8.7 check-in: 90db34b475 user: jan.nijtmans tags: trunk, main
09:19
Merge 8.6 check-in: 7467a34f63 user: jan.nijtmans tags: core-8-branch
08:23
Merge 8.5. Restore use of AC_HEADER_STDC in win/configure.in: Wait for 8.7 to make that change check-in: 7e11bc3733 user: jan.nijtmans tags: core-8-6-branch
2021-01-04
16:46
Merge 8.6 check-in: 8f50937f8a user: jan.nijtmans tags: core-8-branch

Changes to doc/define.n.

488
489
490
491
492
493
494






495
496
497
498
499
500
501
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507






+
+
+
+
+
+







of values (class names, variable names, etc.) that comprises the contents of
the slot. The class defines five operations (as methods) that may be done on
the slot:
.TP
\fIslot\fR \fB\-append\fR ?\fImember ...\fR?
.
This appends the given \fImember\fR elements to the slot definition.
.TP
\fIslot\fR \fB\-appendifnew\fR ?\fImember ...\fR?
.VS TIP567
This appends the given \fImember\fR elements to the slot definition if they
do not already exist in the slot.
.VE TIP567
.TP
\fIslot\fR \fB\-clear\fR
.
This sets the slot definition to the empty list.
.TP
\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR?
.VS TIP516

Changes to generic/tclOODefineCmds.c.

2434
2435
2436
2437
2438
2439
2440
2441

2442
2443






2444
2445
2446
2447
2448
2449
2450
2434
2435
2436
2437
2438
2439
2440

2441
2442

2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455






-
+

-
+
+
+
+
+
+







    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc, i;
    int mixinc, i, isNew;
    Tcl_Obj **mixinv;
    Class **mixins;
    Class **mixins;			/* The references to the classes to
					 * actually install. */
    Tcl_HashTable uniqueCheck;		/* Note that this hash table is just
					 * used as a set of class references;
					 * it has no payload values and keys
					 * are always pointers. */

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
2458
2459
2460
2461
2462
2463
2464

2465
2466
2467
2468
2469
2470
2471







2472
2473
2474
2475
2476
2477
2478
2479
2480
2481

2482
2483
2484
2485
2486

2487
2488
2489
2490
2491
2492
2493
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508






+







+
+
+
+
+
+
+










+





+







	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
    Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    i--;
	    goto freeAndError;
	}
	(void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
	if (!isNew) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "class should only be a direct mixin once", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
	    goto freeAndError;
	}
	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "may not mix a class into itself", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
	    goto freeAndError;
	}
    }

    TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
    Tcl_DeleteHashTable(&uniqueCheck);
    TclStackFree(interp, mixins);
    return TCL_OK;

  freeAndError:
    TclStackFree(interp, mixins);
    Tcl_DeleteHashTable(&uniqueCheck);
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassSuperGet, ClassSuperSet --
2836
2837
2838
2839
2840
2841
2842
2843

2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857

2858
2859
2860
2861
2862
2863
2864
2865






-
+







    TclOOObjectSetFilters(oPtr, filterc, filterv);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ObjectMixinGet, ObjectMixinSet --
 * ObjMixinGet, ObjMixinSet --
 *
 *	Implementation of the "mixin" slot accessors of the "oo::objdefine"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

2885
2886
2887
2888
2889
2890
2891
2892

2893
2894
2895






2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910

2911
2912
2913
2914
2915




2916
2917




2918
2919
2920
2921
2922

2923





2924
2925
2926
2927
2928
2929
2930
2900
2901
2902
2903
2904
2905
2906

2907
2908


2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939


2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962






-
+

-
-
+
+
+
+
+
+















+





+
+
+
+
-
-
+
+
+
+





+

+
+
+
+
+







    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc;
    int mixinc, i, isNew;
    Tcl_Obj **mixinv;
    Class **mixins;
    int i;
    Class **mixins;			/* The references to the classes to
					 * actually install. */
    Tcl_HashTable uniqueCheck;		/* Note that this hash table is just
					 * used as a set of class references;
					 * it has no payload values and keys
					 * are always pointers. */

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
    if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
    Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    goto freeAndError;
	}
	(void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
	if (!isNew) {
	    TclStackFree(interp, mixins);
	    return TCL_ERROR;
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "class should only be a direct mixin once", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
	    goto freeAndError;
	}
    }

    TclOOObjectSetMixins(oPtr, mixinc, mixins);
    TclStackFree(interp, mixins);
    Tcl_DeleteHashTable(&uniqueCheck);
    return TCL_OK;

  freeAndError:
    TclStackFree(interp, mixins);
    Tcl_DeleteHashTable(&uniqueCheck);
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------
 *
 * ObjectVarsGet, ObjectVarsSet --
 *

Changes to generic/tclOOScript.h.

94
95
96
97
98
99
100
101

102
103

104
105
106
107
108
109
110
94
95
96
97
98
99
100

101
102

103
104
105
106
107
108
109
110






-
+

-
+







"\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 ::oo::define::superclass -append $d\n"
"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
"\t\t}\n"
"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n"
"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $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"
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
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






-
+




-
+





+
+
+
+
+
+
+
+
+
+
+
-
-
+
+





-
+








-
+








-
-
+







"\t\t}\n"
"\t\tmethod Set list {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Resolve list {\n"
"\t\t\treturn $list\n"
"\t\t}\n"
"\t\tmethod -set args {\n"
"\t\tmethod -set -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\ttailcall my Set $args\n"
"\t\t}\n"
"\t\tmethod -append args {\n"
"\t\tmethod -append -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"
"\t\tmethod -appendifnew -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\tforeach a $args {\n"
"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
"\t\t\t\tif {$a ni $current} {\n"
"\t\t\t\t\tlappend current $a\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\ttailcall my Set $current\n"
"\t\t}\n"
"\t\tmethod -clear {} {tailcall my Set {}}\n"
"\t\tmethod -prepend args {\n"
"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
"\t\tmethod -prepend -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
"\t\t}\n"
"\t\tmethod -remove args {\n"
"\t\tmethod -remove -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [lmap val $current {\n"
"\t\t\t\tif {$val in $args} continue else {set val}\n"
"\t\t\t}]\n"
"\t\t}\n"
"\t\tforward --default-operation my -append\n"
"\t\tmethod unknown {args} {\n"
"\t\tmethod unknown -unexport {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 -prepend -remove\n"
"\t\tunexport unknown destroy\n"
"\t\tunexport 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"

Changes to tests/oo.test.

1680
1681
1682
1683
1684
1685
1686
1687
1688
1689

1690
1691
1692
1693
1694
1695
1696
1697
1698
1699

1700
1701
1702

1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716

1717
1718
1719

1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735

1736
1737
1738

1739
1740
1741
1742
1743
1744
1745
1746
1747
1680
1681
1682
1683
1684
1685
1686



1687

1688
1689
1690
1691
1692
1693
1694


1695



1696


1697
1698
1699
1700
1701
1702
1703
1704
1705
1706


1707



1708


1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720


1721



1722


1723
1724
1725
1726
1727
1728
1729






-
-
-
+
-







-
-
+
-
-
-
+
-
-










-
-
+
-
-
-
+
-
-












-
-
+
-
-
-
+
-
-







	namespace delete $namespace
    }}}

    rename obj1 {}
    # No segmentation fault
    return done
} done

test oo-11.6.1 {
    OO: cleanup of when an class is mixed into itself
test oo-11.6 {OO: cleanup of when an class is mixed into itself} memory {
} -constraints memory -body {
    leaktest {
	interp create interp1
	oo::class create obj1
	::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
	rename obj1 {}
	interp delete interp1
    }
} -result 0 -cleanup {
}
} 0

test oo-11.6.2 {
    OO: cleanup ReleaseClassContents() where class is mixed into one of its
test oo-11.7 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} memory {
    instances
} -constraints memory -body {
    leaktest {
	interp create interp1
	interp1 eval {
	    oo::class create obj1
	    ::oo::copy obj1 obj2
	    rename obj2 {}
	    rename obj1 {}
	}
	interp delete interp1
    }
} -result 0 -cleanup {
}
} 0

test oo-11.6.3 {
    OO: cleanup ReleaseClassContents() where class is mixed into one of its
test oo-11.8 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} memory {
    instances
} -constraints memory -body {
    leaktest {
	interp create interp1
	interp1 eval {
	    oo::class create obj1
	    ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}

	    ::oo::copy obj1 obj2
	    rename obj2 {}
	    rename obj1 {}
	}
	interp delete interp1
    }
} -result 0 -cleanup {
}
} 0

test oo-11.6.4 {
    OO: cleanup ReleaseClassContents() where class is mixed into one of its
test oo-11.9 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -body {
    instances
} -body {
    oo::class create obj1
    ::oo::define obj1 {self mixin [self]}

    ::oo::copy obj1 obj2
    ::oo::objdefine obj2 {mixin [self]}

    ::oo::copy obj2 obj3
2214
2215
2216
2217
2218
2219
2220

























2221
2222
2223
2224
2225
2226
2227
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    oo::class create cls {
	superclass parent
	mixin mix
	method test {} {lappend ::result cls; next; return $::result}
    }
    [cls new] test
} -result {mix cls}
test oo-14.9 {OO: class mixins must be unique in list} -setup {
    oo::class create parent
} -body {
    oo::class create A {superclass parent}
    oo::class create B {
	superclass parent
	mixin A
    }
    oo::define B mixin -append A
} -returnCodes error -cleanup {
    parent destroy
} -result {class should only be a direct mixin once}
test oo-14.10 {OO: instance mixins must be unique in list} -setup {
    oo::class create parent
} -body {
    oo::class create A {superclass parent}
    oo::class create B {
	superclass parent
	constructor {} {oo::objdefine [self] mixin A}
    }
    B create obj
    oo::objdefine obj {mixin -append A}
} -returnCodes error -cleanup {
    parent destroy
} -result {class should only be a direct mixin once}

test oo-15.1 {OO: object cloning} {
    oo::class create Aclass
    oo::define Aclass method test {} {lappend ::result [self object]->test}
    Aclass create Ainstance
    set result {}
    Ainstance test
4193
4194
4195
4196
4197
4198
4199
4200














4201
4202
4203
4204
4205
4206
4207
4200
4201
4202
4203
4204
4205
4206

4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227






-
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    set s [SampleSlot new]
}] -body {
    # Method names beginning with "-" are special to slots
    $s -grill q
} -returnCodes error -cleanup [SampleSlotCleanup {
    rename $s {}
}] -result \
    {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops}
    {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops}
test oo-33.5 {TIP 567: slots -appendifnew} -setup [SampleSlotSetup {
    set s [SampleSlot new]
}] -body {
    list \
	[$s -clear
	 $s contents] \
	[$s -append p q r
	 $s contents] \
	[$s -appendifnew q s r t p
	 $s contents]
} -cleanup [SampleSlotCleanup {
    rename $s {}
}] -result {{} {p q r} {p q r s t}}

test oo-34.1 {TIP 380: slots - presence} -setup {
    set obj [oo::object new]
    set result {}
} -body {
    oo::define oo::object {
	::lappend ::result [::info object class filter]
4223
4224
4225
4226
4227
4228
4229
4230

4231
4232
4233

4234
4235
4236

4237
4238
4239

4240
4241
4242

4243
4244
4245

4246
4247
4248

4249
4250
4251
4252
4253
4254
4255
4243
4244
4245
4246
4247
4248
4249

4250
4251
4252

4253
4254
4255

4256
4257
4258

4259
4260
4261

4262
4263
4264

4265
4266
4267

4268
4269
4270
4271
4272
4273
4274
4275






-
+


-
+


-
+


-
+


-
+


-
+


-
+







} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
proc getMethods obj {
    list [lsort [info object methods $obj -all]] \
	[lsort [info object methods $obj -private]]
}
test oo-34.3 {TIP 380: slots - presence} {
    getMethods oo::define::filter
} {{-append -clear -prepend -remove -set} {Get Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.4 {TIP 380: slots - presence} {
    getMethods oo::define::mixin
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.5 {TIP 380: slots - presence} {
    getMethods oo::define::superclass
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.6 {TIP 380: slots - presence} {
    getMethods oo::define::variable
} {{-append -clear -prepend -remove -set} {Get Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.7 {TIP 380: slots - presence} {
    getMethods oo::objdefine::filter
} {{-append -clear -prepend -remove -set} {Get Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.8 {TIP 380: slots - presence} {
    getMethods oo::objdefine::mixin
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.9 {TIP 380: slots - presence} {
    getMethods oo::objdefine::variable
} {{-append -clear -prepend -remove -set} {Get Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.10 {TIP 516: slots - resolution} -setup {
    oo::class create parent
    set result {}
    oo::class create 516a { superclass parent }
    oo::class create 516b { superclass parent }
    oo::class create 516c { superclass parent }
    namespace eval 516test {

Changes to tests/ooUtil.test.

522
523
524
525
526
527
528























529
530
531
532
533
534
535
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







	}
    }
    cls create o pqr
    list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg
} -cleanup {
    parent destroy
} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}}

# Tests a very weird combination of things (with a key problem locus in
# MixinClassDelegates) that TIP 567 fixes
test ooUtil-8.1 {TIP 567: call oo::define twice from metaclass constructor} -setup {
    oo::class create parent
} -body {
    ::oo::class create A {
	superclass parent
    }
    ::oo::class create B {
	superclass ::oo::class parent
    	constructor {{definitionScript ""}} {
	    next $definitionScript
	    next {superclass ::A}
	}
    }
    B create C {
	superclass A
    }
    C create instance
} -cleanup {
    parent destroy
} -result ::instance

# Tests that verify issues detected with the tcllib version of the code
test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
    oo::class create animal {}
    namespace eval ::ooutiltest {
	oo::class create pet { superclass animal }
    }

Changes to tools/tclOOScript.tcl.

149
150
151
152
153
154
155
156

157
158

159
160
161
162
163
164
165
149
150
151
152
153
154
155

156
157

158
159
160
161
162
163
164
165






-
+

-
+







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

    # ----------------------------------------------------------------------
    #
    # UpdateClassDelegatesAfterClone --
    #
    #	Support code that is like [MixinClassDelegates] except for when a
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
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






-
+




-
+





+
+
+
+
+
+
+
+
+
+
+
-
-
+
+





-
+










-
+









-
+
-
-
+







	# 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 {
	method -set -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    tailcall my Set $args
	}
	method -append args {
	method -append -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [list {*}$current {*}$args]
	}
	method -appendifnew -export args {
	    set my [namespace which my]
	    set current [uplevel 1 [list $my Get]]
	    foreach a $args {
		set a [uplevel 1 [list $my Resolve $a]]
		if {$a ni $current} {
		    lappend current $a
		}
	    }
	    tailcall my Set $current
	}
	method -clear {} {tailcall my Set {}}
	method -prepend args {
	method -clear -export {} {tailcall my Set {}}
	method -prepend -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [list {*}$args {*}$current]
	}
	method -remove args {
	method -remove -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [lmap val $current {
		if {$val in $args} continue else {set val}
	    }]
	}

	# Default handling
	forward --default-operation my -append
	method unknown {args} {
	method unknown -unexport {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
	# Conceal destroy; want slots to persist, please
	export -set -append -clear -prepend -remove
	unexport unknown destroy
	unexport 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