Tcl Source Code

Check-in [f8a55e34de]
Login

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

Overview
Comment:Further work to improve Object reference accounting in order to plug leaks.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | memleak
Files: files | file ages | folders
SHA3-256:f8a55e34de7b1c58f769d4e413554b7077a7b16d4352ea475ae9f887cd22448c
User & Date: pooryorick 2018-03-14 20:43:20
Context
2018-03-14
20:59
A few test hygiene fixes. check-in: 62043ae854 user: dgp tags: memleak
20:43
Further work to improve Object reference accounting in order to plug leaks. check-in: f8a55e34de user: pooryorick tags: memleak
2018-03-13
20:41
Audit and correct Object reference counting issues. check-in: 821793c082 user: pooryorick tags: memleak
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOO.c.

422
423
424
425
426
427
428

429
430
431
432

433
434
435
436
437
438
439
440
441
442
443
444
445
446
...
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
...
656
657
658
659
660
661
662



663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
....
1003
1004
1005
1006
1007
1008
1009

1010
1011


1012
1013
1014
1015
1016
1017
1018
....
1145
1146
1147
1148
1149
1150
1151

1152
1153
1154
1155
1156
1157
1158
....
1833
1834
1835
1836
1837
1838
1839

1840
1841
1842
1843



1844
1845
1846
1847
1848
1849


1850
1851
1852
1853
1854
1855
1856
....
1920
1921
1922
1923
1924
1925
1926

1927
1928
1929
1930
1931
1932
1933
....
1963
1964
1965
1966
1967
1968
1969

1970
1971

1972
1973
1974
1975
1976
1977
1978


1979
1980
1981
1982
1983
1984
1985
     *
     * Corresponding TclOODecrRefCount for all incremented refcounts is in
     * KillFoundation.
     */

    /* Rewire bootstrapped objects. */
    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;

    AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr);

    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
    AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr);


    fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
    fPtr->classCls->flags |= ROOT_CLASS;

    /* Standard initialization for new Objects */
    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
    TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);

    /*
     * Basic method declarations for the core classes.
     */

    for (i=0 ; objMethods[i].name ; i++) {
................................................................................
    Foundation *fPtr = GetFoundation(interp);

    TclDecrRefCount(fPtr->unknownMethodNameObj);
    TclDecrRefCount(fPtr->constructorName);
    TclDecrRefCount(fPtr->destructorName);
    TclDecrRefCount(fPtr->clonedName);
    TclDecrRefCount(fPtr->defineName);
    if (fPtr->objectCls->thisPtr->selfCls != NULL) {
	TclOODecrRefCount(fPtr->objectCls->thisPtr->selfCls->thisPtr);
    }
    if (fPtr->classCls->thisPtr->selfCls != NULL) {
	TclOODecrRefCount(fPtr->classCls->thisPtr->selfCls->thisPtr);
    }
    TclOODecrRefCount(fPtr->objectCls->thisPtr);
    TclOODecrRefCount(fPtr->classCls->thisPtr);

    ckfree(fPtr);
}
 
/*
................................................................................
	 * have to get rid of the error message from Tcl_CreateNamespace,
	 * since that's something that should not be exposed to the user.
	 */

	Tcl_ResetResult(interp);
    }




    ((Namespace *)oPtr->namespacePtr)->refCount++;

    /*
     * Make the namespace know about the helper commands. This grants access
     * to the [self] and [next] commands.
     */

  configNamespace:
    if (fPtr->helpersNs != NULL) {
	TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
    }
    TclOOSetupVariableResolver(oPtr->namespacePtr);

    /*
     * Suppress use of compiled versions of the commands in this object's
................................................................................
	ckfree(clsPtr->metadataPtr);
	clsPtr->metadataPtr = NULL;
    }

    if (clsPtr->mixins.num) {
	FOREACH(tmpClsPtr, clsPtr->mixins) {
	    TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);

	}
	ckfree(clsPtr->mixins.list);


    }

    if (clsPtr->superclasses.num > 0) {
	FOREACH(tmpClsPtr, clsPtr->superclasses) {
	    TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
	    TclOODecrRefCount(tmpClsPtr->thisPtr);
	}
................................................................................

    /* To do: Should this be protected with a * !IsRoot() condition?  */ 
    TclOORemoveFromInstances(oPtr, oPtr->selfCls);

    if (oPtr->mixins.num > 0) {
	FOREACH(mixinPtr, oPtr->mixins) {
	    TclOORemoveFromInstances(oPtr, mixinPtr);

	}
	ckfree(oPtr->mixins.list);
    }

    FOREACH(filterObj, oPtr->filters) {
	TclDecrRefCount(filterObj);
    }
................................................................................
	}
    }

    /*
     * Copy the object's mixin references to the new object.
     */


    FOREACH(mixinPtr, o2Ptr->mixins) {
	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
	    TclOORemoveFromInstances(o2Ptr, mixinPtr);
	}



    }
    DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
    FOREACH(mixinPtr, o2Ptr->mixins) {
	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
	    TclOOAddToInstances(o2Ptr, mixinPtr);
	}


    }

    /*
     * Copy the object's filter list to the new object.
     */

    DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
................................................................................
	/*
	 * Ensure that the new class's superclass structure is the same as the
	 * old class's.
	 */

	FOREACH(superPtr, cls2Ptr->superclasses) {
	    TclOORemoveFromSubclasses(cls2Ptr, superPtr);

	}
	if (cls2Ptr->superclasses.num) {
	    cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
		    sizeof(Class *) * clsPtr->superclasses.num);
	} else {
	    cls2Ptr->superclasses.list =
		    ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
................................................................................
	}

	/*
	 * Duplicate the source class's mixins (which cannot be circular
	 * references to the duplicate).
	 */


	FOREACH(mixinPtr, cls2Ptr->mixins) {
	    TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);

	}
	if (cls2Ptr->mixins.num != 0) {
	    ckfree(clsPtr->mixins.list);
	}
	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
	FOREACH(mixinPtr, cls2Ptr->mixins) {
	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);


	}

	/*
	 * Duplicate the source class's methods, constructor and destructor.
	 */

	FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {







>
|


|
>





<
<







 







<
<
<
<
<
<







 







>
>
>







<







 







>


>
>







 







>







 







>
|
|
|
|
>
>
>






>
>







 







>







 







>
|
|
>
|
<





>
>







422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439


440
441
442
443
444
445
446
...
564
565
566
567
568
569
570






571
572
573
574
575
576
577
...
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666

667
668
669
670
671
672
673
...
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
....
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
....
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
....
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
....
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981

1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
     *
     * Corresponding TclOODecrRefCount for all incremented refcounts is in
     * KillFoundation.
     */

    /* Rewire bootstrapped objects. */
    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
    AddRef(fPtr->classCls->thisPtr);
    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);

    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
    AddRef(fPtr->classCls->thisPtr);
    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);

    fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
    fPtr->classCls->flags |= ROOT_CLASS;

    /* Standard initialization for new Objects */


    TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);

    /*
     * Basic method declarations for the core classes.
     */

    for (i=0 ; objMethods[i].name ; i++) {
................................................................................
    Foundation *fPtr = GetFoundation(interp);

    TclDecrRefCount(fPtr->unknownMethodNameObj);
    TclDecrRefCount(fPtr->constructorName);
    TclDecrRefCount(fPtr->destructorName);
    TclDecrRefCount(fPtr->clonedName);
    TclDecrRefCount(fPtr->defineName);






    TclOODecrRefCount(fPtr->objectCls->thisPtr);
    TclOODecrRefCount(fPtr->classCls->thisPtr);

    ckfree(fPtr);
}
 
/*
................................................................................
	 * have to get rid of the error message from Tcl_CreateNamespace,
	 * since that's something that should not be exposed to the user.
	 */

	Tcl_ResetResult(interp);
    }


  configNamespace:

    ((Namespace *)oPtr->namespacePtr)->refCount++;

    /*
     * Make the namespace know about the helper commands. This grants access
     * to the [self] and [next] commands.
     */


    if (fPtr->helpersNs != NULL) {
	TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
    }
    TclOOSetupVariableResolver(oPtr->namespacePtr);

    /*
     * Suppress use of compiled versions of the commands in this object's
................................................................................
	ckfree(clsPtr->metadataPtr);
	clsPtr->metadataPtr = NULL;
    }

    if (clsPtr->mixins.num) {
	FOREACH(tmpClsPtr, clsPtr->mixins) {
	    TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
	    TclOODecrRefCount(tmpClsPtr->thisPtr);
	}
	ckfree(clsPtr->mixins.list);
	clsPtr->mixins.list = NULL;
	clsPtr->mixins.num = 0;
    }

    if (clsPtr->superclasses.num > 0) {
	FOREACH(tmpClsPtr, clsPtr->superclasses) {
	    TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
	    TclOODecrRefCount(tmpClsPtr->thisPtr);
	}
................................................................................

    /* To do: Should this be protected with a * !IsRoot() condition?  */ 
    TclOORemoveFromInstances(oPtr, oPtr->selfCls);

    if (oPtr->mixins.num > 0) {
	FOREACH(mixinPtr, oPtr->mixins) {
	    TclOORemoveFromInstances(oPtr, mixinPtr);
	    TclOODecrRefCount(mixinPtr->thisPtr);
	}
	ckfree(oPtr->mixins.list);
    }

    FOREACH(filterObj, oPtr->filters) {
	TclDecrRefCount(filterObj);
    }
................................................................................
	}
    }

    /*
     * Copy the object's mixin references to the new object.
     */

    if (o2Ptr->mixins.num != 0) {
	FOREACH(mixinPtr, o2Ptr->mixins) {
	    if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
		TclOORemoveFromInstances(o2Ptr, mixinPtr);
	    }
	    TclOODecrRefCount(mixinPtr->thisPtr);
	}
	ckfree(o2Ptr->mixins.list);
    }
    DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
    FOREACH(mixinPtr, o2Ptr->mixins) {
	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
	    TclOOAddToInstances(o2Ptr, mixinPtr);
	}
	/* For the reference just created in DUPLICATE */
	AddRef(mixinPtr->thisPtr);
    }

    /*
     * Copy the object's filter list to the new object.
     */

    DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
................................................................................
	/*
	 * Ensure that the new class's superclass structure is the same as the
	 * old class's.
	 */

	FOREACH(superPtr, cls2Ptr->superclasses) {
	    TclOORemoveFromSubclasses(cls2Ptr, superPtr);
	    TclOODecrRefCount(superPtr->thisPtr);
	}
	if (cls2Ptr->superclasses.num) {
	    cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
		    sizeof(Class *) * clsPtr->superclasses.num);
	} else {
	    cls2Ptr->superclasses.list =
		    ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
................................................................................
	}

	/*
	 * Duplicate the source class's mixins (which cannot be circular
	 * references to the duplicate).
	 */

	if (cls2Ptr->mixins.num != 0) {
	    FOREACH(mixinPtr, cls2Ptr->mixins) {
		TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }

	    ckfree(clsPtr->mixins.list);
	}
	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
	FOREACH(mixinPtr, cls2Ptr->mixins) {
	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
	    /* For the copy just created in DUPLICATE */
	    AddRef(mixinPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's methods, constructor and destructor.
	 */

	FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {

Changes to generic/tclOODefineCmds.c.

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
359
360
361
362
363
...
379
380
381
382
383
384
385

386
387
388
389
390
391
392
393

394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
....
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
....
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
....
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
....
2193
2194
2195
2196
2197
2198
2199

2200
2201
2202
2203
2204
2205
2206
....
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
    Class *mixinPtr;
    int i;

    if (numMixins == 0) {
	if (oPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, oPtr->mixins) {
		TclOORemoveFromInstances(oPtr, mixinPtr);

	    }
	    ckfree(oPtr->mixins.list);
	    oPtr->mixins.num = 0;
	}
	RecomputeClassCacheFlag(oPtr);
    } else {
	if (oPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, oPtr->mixins) {
		if (mixinPtr && mixinPtr != oPtr->selfCls) {
		    TclOORemoveFromInstances(oPtr, mixinPtr);
		}

	    }
	    oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
		    sizeof(Class *) * numMixins);
	} else {
	    oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
	    oPtr->flags &= ~USE_CLASS_CACHE;
	}
	oPtr->mixins.num = numMixins;
	memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, oPtr->mixins) {
	    if (mixinPtr != oPtr->selfCls) {
		TclOOAddToInstances(oPtr, mixinPtr);
		/* Corresponding TclOODecrRefCount() is in the caller of this
		 * function. 
		 */
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	}
    }
    oPtr->epoch++;
}
 
/*
................................................................................
    Class *mixinPtr;
    int i;

    if (numMixins == 0) {
	if (classPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, classPtr->mixins) {
		TclOORemoveFromMixinSubs(classPtr, mixinPtr);

	    }
	    ckfree(classPtr->mixins.list);
	    classPtr->mixins.num = 0;
	}
    } else {
	if (classPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, classPtr->mixins) {
		TclOORemoveFromMixinSubs(classPtr, mixinPtr);

	    }
	    classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
		    sizeof(Class *) * numMixins);
	} else {
	    classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
	}
	classPtr->mixins.num = numMixins;
	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, classPtr->mixins) {
	    TclOOAddToMixinSubs(classPtr, mixinPtr);
	    /* Corresponding TclOODecrRefCount() is in the caller of this
	     * function
	     */
	    TclOODecrRefCount(mixinPtr->thisPtr);
	}
    }
    BumpGlobalEpoch(interp, classPtr);
}
 
/*
 * ----------------------------------------------------------------------
................................................................................


    /*
     * Set the object's class.
     */

    if (oPtr->selfCls != clsPtr) {

	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
	TclOODecrRefCount(oPtr->selfCls->thisPtr);
	oPtr->selfCls = clsPtr;
	AddRef(oPtr->selfCls->thisPtr);
	TclOOAddToInstances(oPtr, oPtr->selfCls);

	if (oPtr->classPtr != NULL) {
................................................................................
	if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "may not mix a class into itself", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
	    goto freeAndError;
	}
	mixins[i-1] = clsPtr;
	/* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins,
	 * TclOOClassSetMixinsk, or just below if this function fails.
	 */
	AddRef(mixins[i-1]->thisPtr);
    }

    if (isInstanceMixin) {
	TclOOObjectSetMixins(oPtr, objc-1, mixins);
    } else {
	TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
    }

    TclStackFree(interp, mixins);
    return TCL_OK;

  freeAndError:
    while (--i > 0) {
	TclOODecrRefCount(mixins[i]->thisPtr);
    }
    TclStackFree(interp, mixins);
    return TCL_ERROR;
}
 
/*
 * ----------------------------------------------------------------------
 *
................................................................................
	}
	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;
	}
	/* Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or just
	 * below if this function fails
	 */
	AddRef(mixins[i]->thisPtr);
    }

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

  freeAndError:
    while (i-- > 0) {
	TclOODecrRefCount(mixins[i]->thisPtr);
    }
    TclStackFree(interp, mixins);
    return TCL_ERROR;
}
 
/*
 * ----------------------------------------------------------------------
 *
................................................................................
     * it used to be a member of and splicing it into the new superclasses'
     * subclass list.
     */

    if (oPtr->classPtr->superclasses.num != 0) {
	FOREACH(superPtr, oPtr->classPtr->superclasses) {
	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);

	}
	ckfree((char *) oPtr->classPtr->superclasses.list);
    }
    oPtr->classPtr->superclasses.list = superclasses;
    oPtr->classPtr->superclasses.num = superc;
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	TclOOAddToSubclasses(oPtr->classPtr, superPtr);
................................................................................

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i=0 ; i<mixinc ; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    while (i-- > 0) {
		TclOODecrRefCount(mixins[i]->thisPtr);
	    }
	    TclStackFree(interp, mixins);
	    return TCL_ERROR;
	}
	/* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or
	 * just above if this function fails.
	 */
	AddRef(mixins[i]->thisPtr);
    }

    TclOOObjectSetMixins(oPtr, mixinc, mixins);
    TclStackFree(interp, mixins);
    return TCL_OK;
}
 







>











>












|
<
<
|







 







>








>










|
<
<
|







 







<







 







<
<
<
<












<
<
<







 







<
<
<
<







<
<
<







 







>







 







<
<
<



<
<
<
<







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
359
360
361
362
363
...
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406


407
408
409
410
411
412
413
414
....
1121
1122
1123
1124
1125
1126
1127

1128
1129
1130
1131
1132
1133
1134
....
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
....
2018
2019
2020
2021
2022
2023
2024




2025
2026
2027
2028
2029
2030
2031



2032
2033
2034
2035
2036
2037
2038
....
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
....
2476
2477
2478
2479
2480
2481
2482



2483
2484
2485




2486
2487
2488
2489
2490
2491
2492
    Class *mixinPtr;
    int i;

    if (numMixins == 0) {
	if (oPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, oPtr->mixins) {
		TclOORemoveFromInstances(oPtr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    ckfree(oPtr->mixins.list);
	    oPtr->mixins.num = 0;
	}
	RecomputeClassCacheFlag(oPtr);
    } else {
	if (oPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, oPtr->mixins) {
		if (mixinPtr && mixinPtr != oPtr->selfCls) {
		    TclOORemoveFromInstances(oPtr, mixinPtr);
		}
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
		    sizeof(Class *) * numMixins);
	} else {
	    oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
	    oPtr->flags &= ~USE_CLASS_CACHE;
	}
	oPtr->mixins.num = numMixins;
	memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, oPtr->mixins) {
	    if (mixinPtr != oPtr->selfCls) {
		TclOOAddToInstances(oPtr, mixinPtr);
		/* For the new copy created by memcpy */


		AddRef(mixinPtr->thisPtr);
	    }
	}
    }
    oPtr->epoch++;
}
 
/*
................................................................................
    Class *mixinPtr;
    int i;

    if (numMixins == 0) {
	if (classPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, classPtr->mixins) {
		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    ckfree(classPtr->mixins.list);
	    classPtr->mixins.num = 0;
	}
    } else {
	if (classPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, classPtr->mixins) {
		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
		    sizeof(Class *) * numMixins);
	} else {
	    classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
	}
	classPtr->mixins.num = numMixins;
	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, classPtr->mixins) {
	    TclOOAddToMixinSubs(classPtr, mixinPtr);
	    /* For the new copy created by memcpy */


	    AddRef(mixinPtr->thisPtr);
	}
    }
    BumpGlobalEpoch(interp, classPtr);
}
 
/*
 * ----------------------------------------------------------------------
................................................................................


    /*
     * Set the object's class.
     */

    if (oPtr->selfCls != clsPtr) {

	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
	TclOODecrRefCount(oPtr->selfCls->thisPtr);
	oPtr->selfCls = clsPtr;
	AddRef(oPtr->selfCls->thisPtr);
	TclOOAddToInstances(oPtr, oPtr->selfCls);

	if (oPtr->classPtr != NULL) {
................................................................................
	if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "may not mix a class into itself", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
	    goto freeAndError;
	}
	mixins[i-1] = clsPtr;




    }

    if (isInstanceMixin) {
	TclOOObjectSetMixins(oPtr, objc-1, mixins);
    } else {
	TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
    }

    TclStackFree(interp, mixins);
    return TCL_OK;

  freeAndError:



    TclStackFree(interp, mixins);
    return TCL_ERROR;
}
 
/*
 * ----------------------------------------------------------------------
 *
................................................................................
	}
	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);
    TclStackFree(interp, mixins);
    return TCL_OK;

  freeAndError:



    TclStackFree(interp, mixins);
    return TCL_ERROR;
}
 
/*
 * ----------------------------------------------------------------------
 *
................................................................................
     * it used to be a member of and splicing it into the new superclasses'
     * subclass list.
     */

    if (oPtr->classPtr->superclasses.num != 0) {
	FOREACH(superPtr, oPtr->classPtr->superclasses) {
	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
	    TclOODecrRefCount(superPtr->thisPtr);
	}
	ckfree((char *) oPtr->classPtr->superclasses.list);
    }
    oPtr->classPtr->superclasses.list = superclasses;
    oPtr->classPtr->superclasses.num = superc;
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	TclOOAddToSubclasses(oPtr->classPtr, superPtr);
................................................................................

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i=0 ; i<mixinc ; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {



	    TclStackFree(interp, mixins);
	    return TCL_ERROR;
	}




    }

    TclOOObjectSetMixins(oPtr, mixinc, mixins);
    TclStackFree(interp, mixins);
    return TCL_OK;
}
 

Changes to tests/oo.test.

8
9
10
11
12
13
14







15
16
17
18
19
20
21
...
267
268
269
270
271
272
273














274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
....
1504
1505
1506
1507
1508
1509
1510
1511

















































1512
1513
1514
1515
1516
1517
1518
....
2067
2068
2069
2070
2071
2072
2073











2074
2075
2076
2077
2078
2079
2080
2081
....
3662
3663
3664
3665
3666
3667
3668


3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689










3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758

3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require TclOO 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}








testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
	set lines [split [memory info] \n]
	return [lindex $lines 3 3]
    }
................................................................................
} -body {
    oo::define B constructor {} {A create test-oo-1.18}
    B create C
} -cleanup {
    rename test-oo-1.18 {}
    A destroy
} -result ::C














test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
    proc test-oo-1.18 {} return
} -constraints memory -body {
    leaktest {
	oo::class create A
	oo::class create B {superclass A}
	oo::define B constructor {} {A create test-oo-1.18}
	B create C
	A destroy
    }
} -cleanup {
    rename test-oo-1.18 {}
} -result 0
test oo-1.18.2 {Bug 21c144f0f5} -setup {
    interp create slave
} -body {
    slave eval {
	oo::define [oo::class create foo] superclass oo::class
	oo::class destroy
    }
} -cleanup {
................................................................................
    }}}

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

test oo-11.6 {

















































    OO: cleanup ReleaseClassContents() where class is mixed into one of its
    instances
} -body {
    oo::class create obj1
    ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}

    ::oo::copy obj1 obj2
................................................................................
} -body {
    namespace eval ::existing {}
    oo::copy Cls {} ::existing
} -returnCodes error -cleanup {
    Super destroy
    catch {namespace delete ::existing}
} -result {::existing refers to an existing namespace}











test oo-15.13 {OO: object cloning with target NS} -setup {
    oo::class create Super
    oo::class create Cls {superclass Super}
} -body {
    list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens]
} -cleanup {
    Super destroy
} -result {0 ::Cls2 1}
................................................................................
	}
    }
    list [leaktest {[cls new] destroy}] [info class instances cls]
} -cleanup {
    cls destroy
} -result {0 {}}



oo::class create SampleSlot {
    superclass oo::Slot
    constructor {} {
	variable contents {a b c} ops {}
    }
    method contents {} {variable contents; return $contents}
    method ops {} {variable ops; return $ops}
    method Get {} {
	variable contents
	variable ops
	lappend ops [info level] Get
	return $contents
    }
    method Set {lst} {
	variable contents $lst
	variable ops
	lappend ops [info level] Set $lst
	return
    }
}











test oo-32.1 {TIP 380: slots - class test} -setup {
    SampleSlot create sampleSlot
} -body {
    list [info level] [sampleSlot contents] [sampleSlot ops]
} -cleanup {
    rename sampleSlot {}
} -result {0 {a b c} {}}
test oo-32.2 {TIP 380: slots - class test} -setup {
    SampleSlot create sampleSlot
} -body {
    list [info level] [sampleSlot -clear] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup {
    rename sampleSlot {}
} -result {0 {} {} {1 Set {}}}
test oo-32.3 {TIP 380: slots - class test} -setup {
    SampleSlot create sampleSlot
} -body {
    list [info level] [sampleSlot -append g h i] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup {
    rename sampleSlot {}
} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
test oo-32.4 {TIP 380: slots - class test} -setup {
    SampleSlot create sampleSlot
} -body {
    list [info level] [sampleSlot -set d e f] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup {
    rename sampleSlot {}
} -result {0 {} {d e f} {1 Set {d e f}}}
test oo-32.5 {TIP 380: slots - class test} -setup {
    SampleSlot create sampleSlot
} -body {
    list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup {
    rename sampleSlot {}
} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}

test oo-33.1 {TIP 380: slots - defaulting} -setup {
    set s [SampleSlot new]
} -body {
    list [$s x y] [$s contents]
} -cleanup {
    rename $s {}
} -result {{} {a b c x y}}
test oo-33.2 {TIP 380: slots - defaulting} -setup {
    set s [SampleSlot new]
} -body {
    list [$s destroy; $s unknown] [$s contents]
} -cleanup {
    rename $s {}
} -result {{} {a b c destroy unknown}}
test oo-33.3 {TIP 380: slots - defaulting} -setup {
    set s [SampleSlot new]
} -body {
    oo::objdefine $s forward --default-operation  my -set
    list [$s destroy; $s unknown] [$s contents] [$s ops]
} -cleanup {
    rename $s {}
} -result {{} unknown {1 Set destroy 1 Set unknown}}
test oo-33.4 {TIP 380: slots - errors} -setup {
    set s [SampleSlot new]
} -body {
    # Method names beginning with "-" are special to slots
    $s -grill q
} -returnCodes error -cleanup {
    rename $s {}

} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}

SampleSlot destroy

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]







>
>
>
>
>
>
>







 







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












|







 







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







 







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







 







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

|

|

|
|

|


|

|
|

|


|

|
|

|


|

|
|

|


|

|

|

|

|

|
|

|

|

|
|

|


|

|
|

|


|

>
|
<
<







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
...
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
....
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
....
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
....
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853


3854
3855
3856
3857
3858
3859
3860
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require TclOO 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}


# The foundational objects oo::object and oo::class are sensitive to reference
# counting errors and are deallocated only when an interp is deleted, so in
# this test suite, interp creation and interp deletion are often used in
# leaktests in order to leverage this sensitivity.


testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
	set lines [split [memory info] \n]
	return [lindex $lines 3 3]
    }
................................................................................
} -body {
    oo::define B constructor {} {A create test-oo-1.18}
    B create C
} -cleanup {
    rename test-oo-1.18 {}
    A destroy
} -result ::C
test oo-1.18.1 {no memory leak: superclass} -setup {
} -constraints memory -body {

    leaktest {
	interp create t
	t eval {
	    oo::class create A {
		superclass oo::class
	    }
	}
	interp delete t
    }
} -cleanup {
} -result 0
test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup {
    proc test-oo-1.18 {} return
} -constraints memory -body {
    leaktest {
	oo::class create A
	oo::class create B {superclass A}
	oo::define B constructor {} {A create test-oo-1.18}
	B create C
	A destroy
    }
} -cleanup {
    rename test-oo-1.18 {}
} -result 0
test oo-1.18.3 {Bug 21c144f0f5} -setup {
    interp create slave
} -body {
    slave eval {
	oo::define [oo::class create foo] superclass oo::class
	oo::class destroy
    }
} -cleanup {
................................................................................
    }}}

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

test oo-11.6.1 {
    OO: cleanup of when an class is mixed into itself
} -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 {
}

test oo-11.6.2 {
    OO: cleanup ReleaseClassContents() where class is mixed into one of its
    instances
} -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 {
}

test oo-11.6.3 {
    OO: cleanup ReleaseClassContents() where class is mixed into one of its
    instances
} -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 {
}

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

    ::oo::copy obj1 obj2
................................................................................
} -body {
    namespace eval ::existing {}
    oo::copy Cls {} ::existing
} -returnCodes error -cleanup {
    Super destroy
    catch {namespace delete ::existing}
} -result {::existing refers to an existing namespace}
test oo-15.13.1 {
    OO: object cloning with target NS
    Valgrind will report a leak if the reference count of the namespace isn't
    properly incremented.
} -setup {
    oo::class create Cls {}
} -body {
    oo::copy Cls Cls2 ::dupens
    return done
} -cleanup {
} -result done 
test oo-15.13.2 {OO: object cloning with target NS} -setup {
    oo::class create Super
    oo::class create Cls {superclass Super}
} -body {
    list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens]
} -cleanup {
    Super destroy
} -result {0 ::Cls2 1}
................................................................................
	}
    }
    list [leaktest {[cls new] destroy}] [info class instances cls]
} -cleanup {
    cls destroy
} -result {0 {}}

proc SampleSlotSetup script {
    set script0 {
	oo::class create SampleSlot {
	    superclass oo::Slot
	    constructor {} {
		variable contents {a b c} ops {}
	    }
	    method contents {} {variable contents; return $contents}
	    method ops {} {variable ops; return $ops}
	    method Get {} {
		variable contents
		variable ops
		lappend ops [info level] Get
		return $contents
	    }
	    method Set {lst} {
		variable contents $lst
		variable ops
		lappend ops [info level] Set $lst
		return
	    }
	}
    }
    append script0 \n$script
}

proc SampleSlotCleanup script {
    set script0 {
	SampleSlot destroy
    }
    append script \n$script0
}

test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup {
    SampleSlot create sampleSlot
}] -body {
    list [info level] [sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
    rename sampleSlot {}
}] -result {0 {a b c} {}}
test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup {
    SampleSlot create sampleSlot
}] -body {
    list [info level] [sampleSlot -clear] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
    rename sampleSlot {}
}] -result {0 {} {} {1 Set {}}}
test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
    SampleSlot create sampleSlot
}] -body {
    list [info level] [sampleSlot -append g h i] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
    rename sampleSlot {}
}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
    SampleSlot create sampleSlot
}] -body {
    list [info level] [sampleSlot -set d e f] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
    rename sampleSlot {}
}] -result {0 {} {d e f} {1 Set {d e f}}}
test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
    SampleSlot create sampleSlot
}] -body {
    list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
    rename sampleSlot {}
}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}

test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
    set s [SampleSlot new]
}] -body {
    list [$s x y] [$s contents]
} -cleanup [SampleSlotCleanup {
    rename $s {}
}] -result {{} {a b c x y}}
test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
    set s [SampleSlot new]
}] -body {
    list [$s destroy; $s unknown] [$s contents]
} -cleanup [SampleSlotCleanup {
    rename $s {}
}] -result {{} {a b c destroy unknown}}
test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
    set s [SampleSlot new]
}] -body {
    oo::objdefine $s forward --default-operation  my -set
    list [$s destroy; $s unknown] [$s contents] [$s ops]
} -cleanup [SampleSlotCleanup {
    rename $s {}
}] -result {{} unknown {1 Set destroy 1 Set unknown}}
test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
    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, -set, contents or ops}



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]