TclOO Package

Check-in [1e72cf94d3]
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:merge key fix from trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | 0.7-rc
Files: files | file ages | folders
SHA1: 1e72cf94d3388b5374628ecbfa773b8224f19652
User & Date: dkf 2012-07-26 21:12:45
Context
2012-09-09
11:51
merge docfix from trunk Closed-Leaf check-in: 4e5718de0a user: dkf tags: release, release-0.7, corresponds-to-Tcl8.6b3, 0.7-rc
2012-07-26
21:12
merge key fix from trunk check-in: 1e72cf94d3 user: dkf tags: 0.7-rc
21:09
[Bug 3547839]: Use the memory management scheme used in version of TclOO that is included in Tcl 8.6; prevents memory accesses to deleted structures! check-in: 7db541b369 user: dkf tags: trunk
2012-07-12
09:43
another copyright date update check-in: 1bb9cebfe7 user: dkf tags: release-0.7-rc, 0.7-rc
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.











1
2
3
4
5
6
7









2012-05-20  Donal K. Fellows  <[email protected]>

	* generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut
	the amount of hackiness in class constructors, and refactor some of
	the error message handling from [oo::define] to be saner in the face
	of odd happenings.

>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
2012-07-26  Donal K. Fellows  <[email protected]>

	* generic/tclOO.c (ObjectRenamedTrace, ReleaseClassContents):
	[Bug 3547839]: Use the memory management scheme used in version of
	TclOO that is included in Tcl 8.6, as that doesn't crash when objects
	are ripped out from underneath its feet.
	(Tcl_NewObjectInstance): [Bug 2903011]: Improve fix of this bug; a
	reference must be held from before the constructor is invoked to after
	any resulting deletions are done.

2012-05-20  Donal K. Fellows  <[email protected]>

	* generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut
	the amount of hackiness in class constructors, and refactor some of
	the error message handling from [oo::define] to be saner in the face
	of odd happenings.

Changes to generic/tclOO.c.

187
188
189
190
191
192
193














194
195
196
197
198
199
200
...
353
354
355
356
357
358
359

360
361
362
363
364

365
366
367
368
369
370
371
...
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
...
740
741
742
743
744
745
746





747
748
749




750
751

752
753


754
755
756
757
758
759
760
761
762
763
764
765
766
...
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797









798
799



800
801




802
803
804
805
806
807
808
...
814
815
816
817
818
819
820

821
822
823

824






















825

826
827
828

829
830
831

832
833
834
835

836

837
838
839


840
841
842
843

844
845
846
847


848
849
850
851
852
853
854
855

856
857

858
859


860

861
862
863
864



865
866
867
868


869
870
871

872
873
874
875
876
877
878


879

880
881
882
883



884

885
886


887
888
889
890
891
892
893
894
895



896

897












898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918




919
920
921
922
923
924
925
926
927
928




929
930
931
932
933
934
935
936
937
...
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
....
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053

1054
1055
1056
1057
1058
1059
1060
....
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
....
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
....
1151
1152
1153
1154
1155
1156
1157



1158
1159
1160
1161
1162
1163

1164
1165
1166
1167
1168
1169
1170
....
1177
1178
1179
1180
1181
1182
1183



1184
1185
1186
1187
1188
1189
1190
....
1219
1220
1221
1222
1223
1224
1225



1226
1227
1228
1229
1230
1231

1232
1233
1234
1235
1236
1237
1238
....
1245
1246
1247
1248
1249
1250
1251



1252
1253
1254
1255
1256
1257
1258
....
1287
1288
1289
1290
1291
1292
1293



1294
1295
1296
1297
1298
1299

1300
1301
1302
1303
1304
1305
1306
....
1313
1314
1315
1316
1317
1318
1319



1320
1321
1322
1323
1324
1325
1326
....
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506

1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532



1533
1534
1535
1536
1537
1538
1539
....
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
....
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
extern const TclStubs *const tclOOConstStubsPtr;

/*
 * Key into the interpreter assocData table for the foundation structure ref.
 */

#define FOUNDATION_KEY "tcl/tip257/foundation"














 
/*
 * ----------------------------------------------------------------------
 *
 * Tcloo_Init, Tcloo_SafeInit --
 *
 *	Called to initialise the OO system within an interpreter.
................................................................................

    fPtr->objectCls = AllocClass(interp, AllocObject(fPtr, interp,
	    "::oo::object", NULL), fPtr);
    fPtr->classCls = AllocClass(interp, AllocObject(fPtr, interp,
	    "::oo::class", NULL), fPtr);
    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
    fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;

    fPtr->objectCls->superclasses.num = 0;
    ckfree((char *) fPtr->objectCls->superclasses.list);
    fPtr->objectCls->superclasses.list = NULL;
    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
    fPtr->classCls->thisPtr->flags |= ROOT_CLASS;

    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
    AddRef(fPtr->objectCls->thisPtr);
    AddRef(fPtr->objectCls);

    /*
     * Basic method declarations for the core classes.
................................................................................
    ClientData clientData,	/* The object being deleted. */
    Tcl_Interp *interp,		/* The interpreter containing the object. */
    const char *oldName,	/* What the object was (last) called. */
    const char *newName,	/* Always NULL. */
    int flags)			/* Why was the object deleted? */
{
    Object *oPtr = clientData;
    Class *clsPtr;

    /*
     * If this is a rename and not a delete of the object, we just flush the
     * cache of the object name.
     */

    if (flags & TCL_TRACE_RENAME) {
................................................................................
     * destructors and deleting the object's namespace, which in turn causes
     * the real object structures to be deleted.
     *
     * Note that it is possible for the namespace to be deleted before the
     * command. Because of that case, we must take care here to mark the
     * command as being deleted so that if we return here we don't run into
     * reentrancy problems.





     */

    AddRef(oPtr);




    oPtr->command = NULL;
    oPtr->flags |= OBJECT_DELETED;

    if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
	CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR);



	oPtr->flags |= DESTRUCTOR_CALLED;
	if (contextPtr != NULL) {
	    int result;
	    Tcl_InterpState state;

	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = TclOOInvokeContext(interp, contextPtr, 0, NULL);
	    if (result != TCL_OK) {
		Tcl_BackgroundError(interp);
	    }
................................................................................
    }

    /*
     * OK, the destructor's been run. Time to splat the class data (if any)
     * and nuke the namespace (which triggers the final crushing of the object
     * structure itself).
     *
     * The class of classes needs some special care; if it is deleted (and
     * we're not killing the whole interpreter) we force the delete of the
     * class of objects now as well. Due to the incestuous nature of those two
     * classes, if one goes the other must too and yet the tangle can
     * sometimes not go away automatically; we force it here. [Bug 2962664]
     */

    if (!Tcl_InterpDeleted(interp)) {
	if ((oPtr->flags & ROOT_OBJECT) && oPtr->fPtr->classCls != NULL) {
	    Tcl_DeleteCommandFromToken(interp,
		    oPtr->fPtr->classCls->thisPtr->command);
	} else if (oPtr->flags & ROOT_CLASS) {
	    oPtr->fPtr->classCls = NULL;
	}
    }

    clsPtr = oPtr->classPtr;
    if (clsPtr != NULL) {
	AddRef(clsPtr);
	ReleaseClassContents(interp, oPtr);
    }









    Tcl_DeleteNamespace(oPtr->namespacePtr);
    if (clsPtr) {



	DelRef(clsPtr);
    }




    DelRef(oPtr);
}
 
/*
 * ----------------------------------------------------------------------
 *
 * ReleaseClassContents --
................................................................................
 */

static void
ReleaseClassContents(
    Tcl_Interp *interp,		/* The interpreter containing the class. */
    Object *oPtr)		/* The object representing the class. */
{

    int i;
    Class *clsPtr = oPtr->classPtr, *subclassPtr;
    Object *instancePtr;
























    FOREACH(subclassPtr, clsPtr->mixinSubs) {

	AddRef(subclassPtr);
	AddRef(subclassPtr->thisPtr);
    }

    FOREACH(subclassPtr, clsPtr->subclasses) {
	if (!(oPtr->flags & ROOT_OBJECT)
		|| (subclassPtr->thisPtr->flags & ROOT_CLASS)) {

	    AddRef(subclassPtr);
	    AddRef(subclassPtr->thisPtr);
	}
    }

    FOREACH(instancePtr, clsPtr->instances) {

	AddRef(instancePtr);
    }



    /*
     * Must empty list before processing the members of the list so that
     * things happen in the correct order even if something tries to play
     * fast-and-loose.

     */

    if (clsPtr->mixinSubs.size > 0) {
	LIST_DYNAMIC(struct Class *) mixinSubs;



	TEMP_AND_CLEAR(mixinSubs, clsPtr->mixinSubs);
	FOREACH(subclassPtr, mixinSubs) {
	    register Object *subObj = subclassPtr->thisPtr;

	    if (!(subObj->flags & OBJECT_DELETED)) {
		subObj->flags |= OBJECT_DELETED;
		Tcl_DeleteCommandFromToken(interp, subObj->command);

	    }
	    DelRef(subObj);

	    DelRef(subclassPtr);
	}


	ckfree((char *) mixinSubs.list);

    }

    if (clsPtr->subclasses.size > 0) {
	LIST_DYNAMIC(Class *) subclasses;




	TEMP_AND_CLEAR(subclasses, clsPtr->subclasses);
	FOREACH(subclassPtr, subclasses) {
	    register Object *subObj = subclassPtr->thisPtr;



	    if (!(subObj->flags & OBJECT_DELETED)) {
		subObj->flags |= OBJECT_DELETED;

		Tcl_DeleteCommandFromToken(interp, subObj->command);
	    }
	    if (!(oPtr->flags & ROOT_OBJECT) || (subObj->flags & ROOT_CLASS)) {
		DelRef(subObj);
		DelRef(subclassPtr);
	    }
	}


	ckfree((char *) subclasses.list);

    }
    if (oPtr->flags & ROOT_CLASS) {
	oPtr->fPtr->classCls = NULL;
    }





    if (clsPtr->instances.size > 0) {
	LIST_DYNAMIC(Object *) instances;



	TEMP_AND_CLEAR(instances, clsPtr->instances);
	FOREACH(instancePtr, instances) {
	    if (!(instancePtr->flags & OBJECT_DELETED)) {
		instancePtr->flags |= OBJECT_DELETED;
		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
	    }
	    DelRef(instancePtr);
	}



	ckfree((char *) instances.list);

    }













    if (clsPtr->constructorChainPtr) {
	TclOODeleteChain(clsPtr->constructorChainPtr);
	clsPtr->constructorChainPtr = NULL;
    }
    if (clsPtr->destructorChainPtr) {
	TclOODeleteChain(clsPtr->destructorChainPtr);
	clsPtr->destructorChainPtr = NULL;
    }
    if (clsPtr->classChainCache) {
	FOREACH_HASH_DECLS;
	CallChain *callPtr;

	FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
	    TclOODeleteChain(callPtr);
	}
	Tcl_DeleteHashTable(clsPtr->classChainCache);
	ckfree((char *) clsPtr->classChainCache);
	clsPtr->classChainCache = NULL;
    }





    if (clsPtr->filters.num) {
	Tcl_Obj *filterObj;

	FOREACH(filterObj, clsPtr->filters) {
	    Tcl_DecrRefCount(filterObj);
	}
	ckfree((char *) clsPtr->filters.list);
	clsPtr->filters.num = 0;
    }





    if (clsPtr->metadataPtr != NULL) {
	FOREACH_HASH_DECLS;
	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value;

	FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(clsPtr->metadataPtr);
................................................................................
				 * being deleted. */
{
    Object *oPtr = clientData;
    FOREACH_HASH_DECLS;
    Class *clsPtr = oPtr->classPtr, *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj;
    int i, preserved = !(oPtr->flags & OBJECT_DELETED);

    /*
     * Instruct everyone to no longer use any allocated fields of the object.
     * Also delete the commands that refer to the object at this point (if
     * they still exist) because otherwise their references to the object
     * point into freed memory, allowing crashes.
     */

    oPtr->flags |= OBJECT_DELETED;
    if (oPtr->command) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
    }
    if (oPtr->myCommand) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
    }
    if (preserved) {
	AddRef(oPtr);
	if (clsPtr != NULL) {
	    AddRef(clsPtr);
	    ReleaseClassContents(NULL, oPtr);
	}
    }

    /*
     * Splice the object out of its context. After this, we must *not* call
     * methods on the object.
     */

    if (!(oPtr->flags & ROOT_OBJECT)) {
	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
    }

    FOREACH(mixinPtr, oPtr->mixins) {
	TclOORemoveFromInstances(oPtr, mixinPtr);
    }
    if (i) {
................................................................................
	}
	Tcl_DeleteHashTable(oPtr->metadataPtr);
	ckfree((char *) oPtr->metadataPtr);
	oPtr->metadataPtr = NULL;
    }

    if (clsPtr != NULL) {
	Class *superPtr, *mixinPtr;

	if (clsPtr->metadataPtr != NULL) {
	    FOREACH_HASH_DECLS;
	    Tcl_ObjectMetadataType *metadataTypePtr;
	    ClientData value;


	    FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
		metadataTypePtr->deleteProc(value);
	    }
	    Tcl_DeleteHashTable(clsPtr->metadataPtr);
	    ckfree((char *) clsPtr->metadataPtr);
	    clsPtr->metadataPtr = NULL;
	}
................................................................................
	    Tcl_DecrRefCount(filterObj);
	}
	if (i) {
	    ckfree((char *) clsPtr->filters.list);
	    clsPtr->filters.num = 0;
	}
	FOREACH(mixinPtr, clsPtr->mixins) {
	    if (!(mixinPtr->thisPtr->flags & OBJECT_DELETED)) {
		TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
	    }
	}
	if (i) {
	    ckfree((char *) clsPtr->mixins.list);
	    clsPtr->mixins.num = 0;
	}
	FOREACH(superPtr, clsPtr->superclasses) {
	    if (!(superPtr->thisPtr->flags & OBJECT_DELETED)) {
		TclOORemoveFromSubclasses(clsPtr, superPtr);
	    }
	}
	if (i) {
	    ckfree((char *) clsPtr->superclasses.list);
	    clsPtr->superclasses.num = 0;
	}
................................................................................
    }

    /*
     * Delete the object structure itself.
     */

    DelRef(oPtr);
    if (preserved) {
	if (clsPtr) {
	    DelRef(clsPtr);
	}
	DelRef(oPtr);
    }
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOORemoveFromInstances --
 *
................................................................................
	if (oPtr == instPtr) {
	    goto removeInstance;
	}
    }
    return;

  removeInstance:



    clsPtr->instances.num--;
    if (i < clsPtr->instances.num) {
	clsPtr->instances.list[i] =
		clsPtr->instances.list[clsPtr->instances.num];
    }
    clsPtr->instances.list[clsPtr->instances.num] = NULL;

}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToInstances --
 *
................................................................................
void
TclOOAddToInstances(
    Object *oPtr,		/* The instance to add. */
    Class *clsPtr)		/* The class to add the instance to. It is
				 * assumed that the class is not already
				 * present as an instance in the class. */
{



    if (clsPtr->instances.num >= clsPtr->instances.size) {
	clsPtr->instances.size += ALLOC_CHUNK;
	if (clsPtr->instances.size == ALLOC_CHUNK) {
	    clsPtr->instances.list = (Object **)
		    ckalloc(sizeof(Object *) * ALLOC_CHUNK);
	} else {
	    clsPtr->instances.list = (Object **)
................................................................................
	if (subPtr == subclsPtr) {
	    goto removeSubclass;
	}
    }
    return;

  removeSubclass:



    superPtr->subclasses.num--;
    if (i < superPtr->subclasses.num) {
	superPtr->subclasses.list[i] =
		superPtr->subclasses.list[superPtr->subclasses.num];
    }
    superPtr->subclasses.list[superPtr->subclasses.num] = NULL;

}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToSubclasses --
 *
................................................................................
void
TclOOAddToSubclasses(
    Class *subPtr,		/* The subclass to add. */
    Class *superPtr)		/* The superclass to add the subclass to. It
				 * is assumed that the class is not already
				 * present as a subclass in the superclass. */
{



    if (superPtr->subclasses.num >= superPtr->subclasses.size) {
	superPtr->subclasses.size += ALLOC_CHUNK;
	if (superPtr->subclasses.size == ALLOC_CHUNK) {
	    superPtr->subclasses.list = (Class **)
		    ckalloc(sizeof(Class *) * ALLOC_CHUNK);
	} else {
	    superPtr->subclasses.list = (Class **)
................................................................................
	if (subPtr == subclsPtr) {
	    goto removeSubclass;
	}
    }
    return;

  removeSubclass:



    superPtr->mixinSubs.num--;
    if (i < superPtr->mixinSubs.num) {
	superPtr->mixinSubs.list[i] =
		superPtr->mixinSubs.list[superPtr->mixinSubs.num];
    }
    superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;

}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToMixinSubs --
 *
................................................................................
void
TclOOAddToMixinSubs(
    Class *subPtr,		/* The subclass to add. */
    Class *superPtr)		/* The superclass to add the subclass to. It
				 * is assumed that the class is not already
				 * present as a subclass in the superclass. */
{



    if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
	superPtr->mixinSubs.size += ALLOC_CHUNK;
	if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
	    superPtr->mixinSubs.list = (Class **)
		    ckalloc(sizeof(Class *) * ALLOC_CHUNK);
	} else {
	    superPtr->mixinSubs.list = (Class **)
................................................................................
	    Tcl_InterpState state;

	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    contextPtr->callPtr->flags |= CONSTRUCTOR;
	    contextPtr->skip = skip;

	    /*
	     * Adjust the ensmble tracking record if necessary. [Bug 3514761]
	     */

	    if (((Interp*) interp)->ensembleRewrite.sourceObjs) {
		((Interp*) interp)->ensembleRewrite.numInsertedObjs += skip-1;
		((Interp*) interp)->ensembleRewrite.numRemovedObjs += skip-1;
	    }

	    result = TclOOInvokeContext(interp, contextPtr, objc, objv);
	    flags = oPtr->flags;

	    /*
	     * It's an error if the object was whacked in the constructor.
	     * Force this if it isn't already an error (don't want to lose
	     * errors by accident...)  [Bug 2903011]
	     */

	    if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
		Tcl_SetResult(interp, "object deleted in constructor",
			TCL_STATIC);
		result = TCL_ERROR;
	    }
	    TclOODeleteContext(contextPtr);
	    if (result != TCL_OK) {
		Tcl_DiscardInterpState(state);

		/*
		 * Take care to not delete a deleted object; that would be
		 * bad. [Bug 2903011]
		 */

		if (!(flags & OBJECT_DELETED)) {
		    Tcl_DeleteCommandFromToken(interp, oPtr->command);
		}



		return NULL;
	    }
	    Tcl_RestoreInterpState(interp, state);
	}
    }

    return (Tcl_Object) oPtr;
................................................................................
    Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
    int i, result;

    /*
     * Sanity check.
     */

    if (oPtr->flags & ROOT_CLASS) {
	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
	return NULL;
    }

    /*
     * Build the instance. Note that this does not run any constructors.
     */
................................................................................
    return (Tcl_Class) ((Object *)object)->classPtr;
}

int
Tcl_ObjectDeleted(
    Tcl_Object object)
{
    return (((Object *)object)->flags & OBJECT_DELETED) ? 1 : 0;
}

Tcl_Object
Tcl_GetClassAsObject(
    Tcl_Class clazz)
{
    return (Tcl_Object) ((Class *)clazz)->thisPtr;






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







 







>





>







 







|







 







>
>
>
>
>



>
>
>
>

<
>
|

>
>



<
<
<







 







|

|




|
|
|
<
<
<
|
|
<
|
<
|


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

>
>
>
>







 







>

|

>

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

<
<
>




>
|
>
|
|
|
>
>

<
<
<
>


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


<
<
>
>
>

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

<
<
|
>
>
>

>
|
<
>
>
|
<
|
<
<




>
>
>
|
>

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










<










>
>
>
>










>
>
>
>

<







 







|








<





<
<
<
<
<
<
<







|







 







|
<
<
<
|
|

>







 







|








|







 







<
<
<
<
<
<







 







>
>
>
|
|
|
|
|
|
>







 







>
>
>







 







>
>
>
|
|
|
|
|
|
>







 







>
>
>







 







>
>
>
|
|
|
|
|
|
>







 







>
>
>







 







|






>









|





|
<
<





<
|
|
>
>
>







 







|







 







|







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
...
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
...
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
...
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775

776
777
778
779
780
781
782
783



784
785
786
787
788
789
790
...
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810



811
812

813

814
815
816
817
818
819
820
821
822
823
824
825
826

827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
...
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889


890
891
892
893
894
895
896
897
898
899
900
901
902
903



904
905
906
907

908
909
910


911



912
913
914

915
916
917
918
919
920
921
922
923


924
925
926
927

928

929
930
931


932
933
934

935
936
937

938
939
940
941
942


943
944
945
946
947
948
949

950
951
952

953


954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985

986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014

1015
1016
1017
1018
1019
1020
1021
....
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058

1059
1060
1061
1062
1063







1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
....
1116
1117
1118
1119
1120
1121
1122
1123



1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
....
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
....
1189
1190
1191
1192
1193
1194
1195






1196
1197
1198
1199
1200
1201
1202
....
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
....
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
....
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
....
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
....
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
....
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
....
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612


1613
1614
1615
1616
1617

1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
....
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
....
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
extern const TclStubs *const tclOOConstStubsPtr;

/*
 * Key into the interpreter assocData table for the foundation structure ref.
 */

#define FOUNDATION_KEY "tcl/tip257/foundation"

/*
 * Macros to make inspecting into the guts of an object cleaner.
 *
 * The ocPtr parameter (only in these macros) is assumed to work fine with
 * either an oPtr or a classPtr. Note that the roots oo::object and oo::class
 * have _both_ their object and class flags tagged with ROOT_OBJECT and
 * ROOT_CLASS respectively.
 */

#define Deleted(oPtr)		(((Object *)(oPtr))->command == NULL)
#define IsRootObject(ocPtr)	((ocPtr)->flags & ROOT_OBJECT)
#define IsRootClass(ocPtr)	((ocPtr)->flags & ROOT_CLASS)
#define IsRoot(ocPtr)		((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
 
/*
 * ----------------------------------------------------------------------
 *
 * Tcloo_Init, Tcloo_SafeInit --
 *
 *	Called to initialise the OO system within an interpreter.
................................................................................

    fPtr->objectCls = AllocClass(interp, AllocObject(fPtr, interp,
	    "::oo::object", NULL), fPtr);
    fPtr->classCls = AllocClass(interp, AllocObject(fPtr, interp,
	    "::oo::class", NULL), fPtr);
    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
    fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
    fPtr->objectCls->flags |= ROOT_OBJECT;
    fPtr->objectCls->superclasses.num = 0;
    ckfree((char *) fPtr->objectCls->superclasses.list);
    fPtr->objectCls->superclasses.list = NULL;
    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
    fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
    fPtr->classCls->flags |= ROOT_CLASS;
    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
    AddRef(fPtr->objectCls->thisPtr);
    AddRef(fPtr->objectCls);

    /*
     * Basic method declarations for the core classes.
................................................................................
    ClientData clientData,	/* The object being deleted. */
    Tcl_Interp *interp,		/* The interpreter containing the object. */
    const char *oldName,	/* What the object was (last) called. */
    const char *newName,	/* Always NULL. */
    int flags)			/* Why was the object deleted? */
{
    Object *oPtr = clientData;
    Foundation *fPtr = oPtr->fPtr;

    /*
     * If this is a rename and not a delete of the object, we just flush the
     * cache of the object name.
     */

    if (flags & TCL_TRACE_RENAME) {
................................................................................
     * destructors and deleting the object's namespace, which in turn causes
     * the real object structures to be deleted.
     *
     * Note that it is possible for the namespace to be deleted before the
     * command. Because of that case, we must take care here to mark the
     * command as being deleted so that if we return here we don't run into
     * reentrancy problems.
     *
     * We also do not run destructors on the core class objects when the
     * interpreter is being deleted; their incestuous nature causes problems
     * in that case when the destructor is partially deleted before the uses
     * of it have gone. [Bug 2949397]
     */

    AddRef(oPtr);
    AddRef(fPtr->classCls);
    AddRef(fPtr->objectCls);
    AddRef(fPtr->classCls->thisPtr);
    AddRef(fPtr->objectCls->thisPtr);
    oPtr->command = NULL;


    if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
	CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR);
	int result;
	Tcl_InterpState state;

	oPtr->flags |= DESTRUCTOR_CALLED;
	if (contextPtr != NULL) {



	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = TclOOInvokeContext(interp, contextPtr, 0, NULL);
	    if (result != TCL_OK) {
		Tcl_BackgroundError(interp);
	    }
................................................................................
    }

    /*
     * OK, the destructor's been run. Time to splat the class data (if any)
     * and nuke the namespace (which triggers the final crushing of the object
     * structure itself).
     *
     * The class of objects needs some special care; if it is deleted (and
     * we're not killing the whole interpreter) we force the delete of the
     * class of classes now as well. Due to the incestuous nature of those two
     * classes, if one goes the other must too and yet the tangle can
     * sometimes not go away automatically; we force it here. [Bug 2962664]
     */

    if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
	    && !Deleted(fPtr->classCls->thisPtr)) {
	Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);



    }


    if (oPtr->classPtr != NULL) {

	AddRef(oPtr->classPtr);
	ReleaseClassContents(interp, oPtr);
    }

    /*
     * The namespace is only deleted if it hasn't already been deleted. [Bug
     * 2950259]
     */

    if (oPtr->namespacePtr != NULL) {
	Tcl_Namespace *namespacePtr = oPtr->namespacePtr;

	oPtr->namespacePtr = NULL;

	Tcl_DeleteNamespace(namespacePtr);
    }
    if (oPtr->classPtr) {
	DelRef(oPtr->classPtr);
    }
    DelRef(fPtr->classCls->thisPtr);
    DelRef(fPtr->objectCls->thisPtr);
    DelRef(fPtr->classCls);
    DelRef(fPtr->objectCls);
    DelRef(oPtr);
}
 
/*
 * ----------------------------------------------------------------------
 *
 * ReleaseClassContents --
................................................................................
 */

static void
ReleaseClassContents(
    Tcl_Interp *interp,		/* The interpreter containing the class. */
    Object *oPtr)		/* The object representing the class. */
{
    FOREACH_HASH_DECLS;
    int i;
    Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
    Object *instancePtr;
    Foundation *fPtr = oPtr->fPtr;

    /*
     * Sanity check!
     */

    if (!Deleted(oPtr)) {
	if (IsRootClass(oPtr)) {
	    Tcl_Panic("deleting class structure for non-deleted %s",
		    "::oo::class");
	} else if (IsRootObject(oPtr)) {
	    Tcl_Panic("deleting class structure for non-deleted %s",
		    "::oo::object");
	} else {
	    Tcl_Panic("deleting class structure for non-deleted %s",
		    "general object");
	}
    }

    /*
     * Lock a number of dependent objects until we've stopped putting our
     * fingers in them.
     */

    FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
	if (mixinSubclassPtr != NULL) {
	    AddRef(mixinSubclassPtr);
	    AddRef(mixinSubclassPtr->thisPtr);
	}
    }
    FOREACH(subclassPtr, clsPtr->subclasses) {


	if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
	    AddRef(subclassPtr);
	    AddRef(subclassPtr->thisPtr);
	}
    }
    if (!IsRootClass(oPtr)) {
	FOREACH(instancePtr, clsPtr->instances) {
	    if (instancePtr != NULL && !IsRoot(instancePtr)) {
		AddRef(instancePtr);
	    }
	}
    }

    /*



     * Squelch classes that this class has been mixed into.
     */

    FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {

	if (mixinSubclassPtr == NULL) {
	    continue;
	}


	if (!Deleted(mixinSubclassPtr->thisPtr)) {



	    Tcl_DeleteCommandFromToken(interp,
		    mixinSubclassPtr->thisPtr->command);
	}

	DelRef(mixinSubclassPtr->thisPtr);
	DelRef(mixinSubclassPtr);
    }
    if (clsPtr->mixinSubs.list != NULL) {
	ckfree((char *) clsPtr->mixinSubs.list);
	clsPtr->mixinSubs.list = NULL;
	clsPtr->mixinSubs.num = 0;
    }



    /*
     * Squelch subclasses of this class.
     */


    FOREACH(subclassPtr, clsPtr->subclasses) {

	if (subclassPtr == NULL || IsRoot(subclassPtr)) {
	    continue;
	}


	if (!Deleted(subclassPtr->thisPtr)) {
	    Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
	}

	DelRef(subclassPtr->thisPtr);
	DelRef(subclassPtr);
    }

    if (clsPtr->subclasses.list != NULL) {
	ckfree((char *) clsPtr->subclasses.list);
	clsPtr->subclasses.list = NULL;
	clsPtr->subclasses.num = 0;
    }



    /*
     * Squelch instances of this class (includes objects we're mixed into).
     */

    if (!IsRootClass(oPtr)) {
	FOREACH(instancePtr, clsPtr->instances) {

	    if (instancePtr == NULL || IsRoot(instancePtr)) {
		continue;
	    }

	    if (!Deleted(instancePtr)) {


		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
	    }
	    DelRef(instancePtr);
	}
    }
    if (clsPtr->instances.list != NULL) {
	ckfree((char *) clsPtr->instances.list);
	clsPtr->instances.list = NULL;
	clsPtr->instances.num = 0;
    }

    /*
     * Special: We delete these after everything else.
     */

    if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
	Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
    }

    /*
     * Squelch method implementation chain caches.
     */

    if (clsPtr->constructorChainPtr) {
	TclOODeleteChain(clsPtr->constructorChainPtr);
	clsPtr->constructorChainPtr = NULL;
    }
    if (clsPtr->destructorChainPtr) {
	TclOODeleteChain(clsPtr->destructorChainPtr);
	clsPtr->destructorChainPtr = NULL;
    }
    if (clsPtr->classChainCache) {

	CallChain *callPtr;

	FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
	    TclOODeleteChain(callPtr);
	}
	Tcl_DeleteHashTable(clsPtr->classChainCache);
	ckfree((char *) clsPtr->classChainCache);
	clsPtr->classChainCache = NULL;
    }

    /*
     * Squelch our filter list.
     */

    if (clsPtr->filters.num) {
	Tcl_Obj *filterObj;

	FOREACH(filterObj, clsPtr->filters) {
	    Tcl_DecrRefCount(filterObj);
	}
	ckfree((char *) clsPtr->filters.list);
	clsPtr->filters.num = 0;
    }

    /*
     * Squelch our metadata.
     */

    if (clsPtr->metadataPtr != NULL) {

	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value;

	FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(clsPtr->metadataPtr);
................................................................................
				 * being deleted. */
{
    Object *oPtr = clientData;
    FOREACH_HASH_DECLS;
    Class *clsPtr = oPtr->classPtr, *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj;
    int i;

    /*
     * Instruct everyone to no longer use any allocated fields of the object.
     * Also delete the commands that refer to the object at this point (if
     * they still exist) because otherwise their references to the object
     * point into freed memory, allowing crashes.
     */


    if (oPtr->command) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
    }
    if (oPtr->myCommand) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);







    }

    /*
     * Splice the object out of its context. After this, we must *not* call
     * methods on the object.
     */

    if (!IsRootObject(oPtr)) {
	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
    }

    FOREACH(mixinPtr, oPtr->mixins) {
	TclOORemoveFromInstances(oPtr, mixinPtr);
    }
    if (i) {
................................................................................
	}
	Tcl_DeleteHashTable(oPtr->metadataPtr);
	ckfree((char *) oPtr->metadataPtr);
	oPtr->metadataPtr = NULL;
    }

    if (clsPtr != NULL) {
	Class *superPtr;



	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value;

	if (clsPtr->metadataPtr != NULL) {
	    FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
		metadataTypePtr->deleteProc(value);
	    }
	    Tcl_DeleteHashTable(clsPtr->metadataPtr);
	    ckfree((char *) clsPtr->metadataPtr);
	    clsPtr->metadataPtr = NULL;
	}
................................................................................
	    Tcl_DecrRefCount(filterObj);
	}
	if (i) {
	    ckfree((char *) clsPtr->filters.list);
	    clsPtr->filters.num = 0;
	}
	FOREACH(mixinPtr, clsPtr->mixins) {
	    if (!Deleted(mixinPtr->thisPtr)) {
		TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
	    }
	}
	if (i) {
	    ckfree((char *) clsPtr->mixins.list);
	    clsPtr->mixins.num = 0;
	}
	FOREACH(superPtr, clsPtr->superclasses) {
	    if (!Deleted(superPtr->thisPtr)) {
		TclOORemoveFromSubclasses(clsPtr, superPtr);
	    }
	}
	if (i) {
	    ckfree((char *) clsPtr->superclasses.list);
	    clsPtr->superclasses.num = 0;
	}
................................................................................
    }

    /*
     * Delete the object structure itself.
     */

    DelRef(oPtr);






}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOORemoveFromInstances --
 *
................................................................................
	if (oPtr == instPtr) {
	    goto removeInstance;
	}
    }
    return;

  removeInstance:
    if (Deleted(clsPtr->thisPtr)) {
	clsPtr->instances.list[i] = NULL;
    } else {
	clsPtr->instances.num--;
	if (i < clsPtr->instances.num) {
	    clsPtr->instances.list[i] =
		    clsPtr->instances.list[clsPtr->instances.num];
	}
	clsPtr->instances.list[clsPtr->instances.num] = NULL;
    }
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToInstances --
 *
................................................................................
void
TclOOAddToInstances(
    Object *oPtr,		/* The instance to add. */
    Class *clsPtr)		/* The class to add the instance to. It is
				 * assumed that the class is not already
				 * present as an instance in the class. */
{
    if (Deleted(clsPtr->thisPtr)) {
	return;
    }
    if (clsPtr->instances.num >= clsPtr->instances.size) {
	clsPtr->instances.size += ALLOC_CHUNK;
	if (clsPtr->instances.size == ALLOC_CHUNK) {
	    clsPtr->instances.list = (Object **)
		    ckalloc(sizeof(Object *) * ALLOC_CHUNK);
	} else {
	    clsPtr->instances.list = (Object **)
................................................................................
	if (subPtr == subclsPtr) {
	    goto removeSubclass;
	}
    }
    return;

  removeSubclass:
    if (Deleted(superPtr->thisPtr)) {
	superPtr->subclasses.list[i] = NULL;
    } else {
	superPtr->subclasses.num--;
	if (i < superPtr->subclasses.num) {
	    superPtr->subclasses.list[i] =
		    superPtr->subclasses.list[superPtr->subclasses.num];
	}
	superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
    }
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToSubclasses --
 *
................................................................................
void
TclOOAddToSubclasses(
    Class *subPtr,		/* The subclass to add. */
    Class *superPtr)		/* The superclass to add the subclass to. It
				 * is assumed that the class is not already
				 * present as a subclass in the superclass. */
{
    if (Deleted(superPtr->thisPtr)) {
	return;
    }
    if (superPtr->subclasses.num >= superPtr->subclasses.size) {
	superPtr->subclasses.size += ALLOC_CHUNK;
	if (superPtr->subclasses.size == ALLOC_CHUNK) {
	    superPtr->subclasses.list = (Class **)
		    ckalloc(sizeof(Class *) * ALLOC_CHUNK);
	} else {
	    superPtr->subclasses.list = (Class **)
................................................................................
	if (subPtr == subclsPtr) {
	    goto removeSubclass;
	}
    }
    return;

  removeSubclass:
    if (Deleted(superPtr->thisPtr)) {
	superPtr->mixinSubs.list[i] = NULL;
    } else {
	superPtr->mixinSubs.num--;
	if (i < superPtr->mixinSubs.num) {
	    superPtr->mixinSubs.list[i] =
		    superPtr->mixinSubs.list[superPtr->mixinSubs.num];
	}
	superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
    }
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToMixinSubs --
 *
................................................................................
void
TclOOAddToMixinSubs(
    Class *subPtr,		/* The subclass to add. */
    Class *superPtr)		/* The superclass to add the subclass to. It
				 * is assumed that the class is not already
				 * present as a subclass in the superclass. */
{
    if (Deleted(superPtr->thisPtr)) {
	return;
    }
    if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
	superPtr->mixinSubs.size += ALLOC_CHUNK;
	if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
	    superPtr->mixinSubs.list = (Class **)
		    ckalloc(sizeof(Class *) * ALLOC_CHUNK);
	} else {
	    superPtr->mixinSubs.list = (Class **)
................................................................................
	    Tcl_InterpState state;

	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    contextPtr->callPtr->flags |= CONSTRUCTOR;
	    contextPtr->skip = skip;

	    /*
	     * Adjust the ensemble tracking record if necessary. [Bug 3514761]
	     */

	    if (((Interp*) interp)->ensembleRewrite.sourceObjs) {
		((Interp*) interp)->ensembleRewrite.numInsertedObjs += skip-1;
		((Interp*) interp)->ensembleRewrite.numRemovedObjs += skip-1;
	    }
	    AddRef(oPtr);
	    result = TclOOInvokeContext(interp, contextPtr, objc, objv);
	    flags = oPtr->flags;

	    /*
	     * It's an error if the object was whacked in the constructor.
	     * Force this if it isn't already an error (don't want to lose
	     * errors by accident...)  [Bug 2903011]
	     */

	    if (result != TCL_ERROR && Deleted(oPtr)) {
		Tcl_SetResult(interp, "object deleted in constructor",
			TCL_STATIC);
		result = TCL_ERROR;
	    }
	    TclOODeleteContext(contextPtr);
	    if (result != TCL_OK && !Deleted(oPtr)) {


		/*
		 * Take care to not delete a deleted object; that would be
		 * bad. [Bug 2903011]
		 */


		Tcl_DeleteCommandFromToken(interp, oPtr->command);
	    }
	    DelRef(oPtr);
	    if (result != TCL_OK) {
		Tcl_DiscardInterpState(state);
		return NULL;
	    }
	    Tcl_RestoreInterpState(interp, state);
	}
    }

    return (Tcl_Object) oPtr;
................................................................................
    Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
    int i, result;

    /*
     * Sanity check.
     */

    if (IsRootClass(oPtr)) {
	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
	return NULL;
    }

    /*
     * Build the instance. Note that this does not run any constructors.
     */
................................................................................
    return (Tcl_Class) ((Object *)object)->classPtr;
}

int
Tcl_ObjectDeleted(
    Tcl_Object object)
{
    return Deleted(object) ? 1 : 0;
}

Tcl_Object
Tcl_GetClassAsObject(
    Tcl_Class clazz)
{
    return (Tcl_Object) ((Class *)clazz)->thisPtr;

Changes to generic/tclOOInt.h.

586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
	if (len != 0) { \
	    memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \
	} else { \
	    (target).list = NULL; \
	} \
    } while(0)

/*
 * Convenience macro for directing a list into temporary storage and clearing
 * the original list. Used when disposing the list.
 */

#define TEMP_AND_CLEAR(temporary,main) \
    do {						\
	memcpy(&(temporary), &(main), sizeof(main));	\
	memset(&(main), 0, sizeof(main));		\
    } while(0)

/*
 * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release.
 */

#define AddRef(ptr) ((ptr)->refCount++)
#define DelRef(ptr) do {			\
	if (--(ptr)->refCount < 1) {		\






<
<
<
<
<
<
<
<
<
<
<







586
587
588
589
590
591
592











593
594
595
596
597
598
599
	if (len != 0) { \
	    memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \
	} else { \
	    (target).list = NULL; \
	} \
    } while(0)












/*
 * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release.
 */

#define AddRef(ptr) ((ptr)->refCount++)
#define DelRef(ptr) do {			\
	if (--(ptr)->refCount < 1) {		\

Changes to tests/oo.test.

63
64
65
66
67
68
69


70

71
72
73
74
75
76
77
	foo new
	foo destroy
    }
} -constraints memory -result 0
test oo-0.5 {testing literal leak on interp delete} memory {
    leaktest {
	interp create foo


	foo eval {oo::object new}

	interp delete foo
    }
} 0
test oo-0.6 {cleaning the core class pair; way #1} -setup {
    interp create t
    initInterpreter t
} -body {






>
>
|
>







63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
	foo new
	foo destroy
    }
} -constraints memory -result 0
test oo-0.5 {testing literal leak on interp delete} memory {
    leaktest {
	interp create foo
	foo eval {
	    package require TclOO
	    oo::object new
	}
	interp delete foo
    }
} 0
test oo-0.6 {cleaning the core class pair; way #1} -setup {
    interp create t
    initInterpreter t
} -body {