TclOO Package

Check-in [426f9ef2c6]
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:tcl:3d96b7076e Prevent crashes when destroying an object's class inside a method call.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 426f9ef2c6a79dc853d9c51ea97842fab0a70576
User & Date: dkf 2015-11-22 08:36:54
Context
2016-03-01
00:07
Update to 1.0.4 check-in: 0a6e9f1ea3 user: dkf tags: trunk, release, release-1.0.4, corresponds-to-Tcl8.6.5
2015-11-22
08:36
tcl:3d96b7076e Prevent crashes when destroying an object's class inside a method call. check-in: 426f9ef2c6 user: dkf tags: trunk
2015-08-18
17:48
Backport of minor docfixes from tcl:465213d171, tcl:2c509f6291 and tcl:d06b029d9d. check-in: 8887ba1542 user: dkf tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOO.c.

891
892
893
894
895
896
897










898
899
900
901
902
903
904
....
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084

1085

1086
1087
1088
1089
1090
1091
1092
....
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
	if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
	    AddRef(subclassPtr);
	    AddRef(subclassPtr->thisPtr);
	}
    }
    if (!IsRootClass(oPtr)) {
	FOREACH(instancePtr, clsPtr->instances) {










	    if (instancePtr != NULL && !IsRoot(instancePtr)) {
		AddRef(instancePtr);
	    }
	}
    }

    /*
................................................................................
    }

    /*
     * 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) {
	ckfree((char *) oPtr->mixins.list);
    }

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

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

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

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






>
>
>
>
>
>
>
>
>
>







 







|




>
|
>







 







|





|







891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
....
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
....
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
	if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
	    AddRef(subclassPtr);
	    AddRef(subclassPtr->thisPtr);
	}
    }
    if (!IsRootClass(oPtr)) {
	FOREACH(instancePtr, clsPtr->instances) {
	    int j;
	    if (instancePtr->selfCls == clsPtr) {
		instancePtr->flags |= CLASS_GONE;
	    }
	    for(j=0 ; j<instancePtr->mixins.num ; j++) {
		Class *mixin = instancePtr->mixins.list[j];
		if (mixin == clsPtr) {
		    instancePtr->mixins.list[j] = NULL;
		}
	    }
	    if (instancePtr != NULL && !IsRoot(instancePtr)) {
		AddRef(instancePtr);
	    }
	}
    }

    /*
................................................................................
    }

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

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

    FOREACH(mixinPtr, oPtr->mixins) {
	if (mixinPtr) {
	    TclOORemoveFromInstances(oPtr, mixinPtr);
	}
    }
    if (i) {
	ckfree((char *) oPtr->mixins.list);
    }

    FOREACH(filterObj, oPtr->filters) {
	Tcl_DecrRefCount(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.
     */

Changes to generic/tclOODefineCmds.c.

321
322
323
324
325
326
327

328

329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
....
1196
1197
1198
1199
1200
1201
1202



1203
1204
1205
1206
1207
1208
1209
....
2317
2318
2319
2320
2321
2322
2323

2324
2325

2326
2327
2328
2329
2330
2331
2332
{
    Class *mixinPtr;
    int i;

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

		TclOORemoveFromInstances(oPtr, mixinPtr);

	    }
	    ckfree((char *) oPtr->mixins.list);
	    oPtr->mixins.num = 0;
	}
	RecomputeClassCacheFlag(oPtr);
    } else {
	if (oPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, oPtr->mixins) {
		if (mixinPtr != oPtr->selfCls) {
		    TclOORemoveFromInstances(oPtr, mixinPtr);
		}
	    }
	    oPtr->mixins.list = (Class **)
		    ckrealloc((char *) oPtr->mixins.list,
		    sizeof(Class *) * numMixins);
	} else {
................................................................................
     * Set the object's class.
     */

    if (oPtr->selfCls != clsPtr) {
	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
	oPtr->selfCls = clsPtr;
	TclOOAddToInstances(oPtr, oPtr->selfCls);



	if (oPtr->classPtr != NULL) {
	    BumpGlobalEpoch(interp, oPtr->classPtr);
	} else {
	    oPtr->epoch++;
	}
    }
    return TCL_OK;
................................................................................
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(mixinPtr, oPtr->mixins) {

	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, mixinPtr->thisPtr));

    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ObjMixinSet(






>
|
>








|







 







>
>
>







 







>
|
|
>







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
....
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
....
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
{
    Class *mixinPtr;
    int i;

    if (numMixins == 0) {
	if (oPtr->mixins.num != 0) {
	    FOREACH(mixinPtr, oPtr->mixins) {
		if (mixinPtr) {
		    TclOORemoveFromInstances(oPtr, mixinPtr);
		}
	    }
	    ckfree((char *) 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 = (Class **)
		    ckrealloc((char *) oPtr->mixins.list,
		    sizeof(Class *) * numMixins);
	} else {
................................................................................
     * Set the object's class.
     */

    if (oPtr->selfCls != clsPtr) {
	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
	oPtr->selfCls = clsPtr;
	TclOOAddToInstances(oPtr, oPtr->selfCls);
	if (!(clsPtr->thisPtr->flags & OBJECT_DELETED)) {
	    oPtr->flags &= ~CLASS_GONE;
	}
	if (oPtr->classPtr != NULL) {
	    BumpGlobalEpoch(interp, oPtr->classPtr);
	} else {
	    oPtr->epoch++;
	}
    }
    return TCL_OK;
................................................................................
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(mixinPtr, oPtr->mixins) {
	if (mixinPtr) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    TclOOObjectName(interp, mixinPtr->thisPtr));
	}
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ObjMixinSet(

Changes to generic/tclOOInfo.c.

229
230
231
232
233
234
235



236
237
238
239
240
241
242
...
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
...
688
689
690
691
692
693
694



695
696
697
698
699
700
701
....
1294
1295
1296
1297
1298
1299
1300



1301
1302
1303
1304
1305
1306
1307
	if (o2Ptr->classPtr == NULL) {
	    Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]),
		    "\" is not a class", NULL);
	    return TCL_ERROR;
	}

	FOREACH(mixinPtr, oPtr->mixins) {



	    if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
		Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
		return TCL_OK;
	    }
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(
		TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));
................................................................................
	if (o2Ptr == NULL) {
	    goto failPrecondition;
	}
	if (o2Ptr->classPtr != NULL) {
	    Class *mixinPtr;

	    FOREACH(mixinPtr, oPtr->mixins) {
		if (mixinPtr == o2Ptr->classPtr) {
		    result = 1;
		    break;
		}
	    }
	}
	break;
    case IsType:
................................................................................
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(mixinPtr, oPtr->mixins) {



	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, mixinPtr->thisPtr));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
 
................................................................................
    clsPtr = GetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(mixinPtr, clsPtr->mixins) {



	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, mixinPtr->thisPtr));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
 






>
>
>







 







|







 







>
>
>







 







>
>
>







229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
...
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
...
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
....
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
	if (o2Ptr->classPtr == NULL) {
	    Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]),
		    "\" is not a class", NULL);
	    return TCL_ERROR;
	}

	FOREACH(mixinPtr, oPtr->mixins) {
	    if (!mixinPtr) {
		continue;
	    }
	    if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
		Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
		return TCL_OK;
	    }
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(
		TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));
................................................................................
	if (o2Ptr == NULL) {
	    goto failPrecondition;
	}
	if (o2Ptr->classPtr != NULL) {
	    Class *mixinPtr;

	    FOREACH(mixinPtr, oPtr->mixins) {
		if (mixinPtr && mixinPtr == o2Ptr->classPtr) {
		    result = 1;
		    break;
		}
	    }
	}
	break;
    case IsType:
................................................................................
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(mixinPtr, oPtr->mixins) {
	if (!mixinPtr) {
	    continue;
	}
	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, mixinPtr->thisPtr));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
 
................................................................................
    clsPtr = GetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(mixinPtr, clsPtr->mixins) {
	if (!mixinPtr) {
	    continue;
	}
	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, mixinPtr->thisPtr));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
 

Changes to generic/tclOOInt.h.

195
196
197
198
199
200
201



202
203
204
205
206
207
208
    LIST_STATIC(Tcl_Obj *) variables;
} Object;

#define OBJECT_DELETED	1	/* Flag to say that an object has been
				 * destroyed. */
#define DESTRUCTOR_CALLED 2	/* Flag to say that the destructor has been
				 * called. */



#define ROOT_OBJECT 0x1000	/* Flag to say that this object is the root of
				 * the class hierarchy and should be treated
				 * specially during teardown. */
#define FILTER_HANDLING 0x2000	/* Flag set when the object is processing a
				 * filter; when set, filters are *not*
				 * processed on the object, preventing nasty
				 * recursive filtering problems. */






>
>
>







195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
    LIST_STATIC(Tcl_Obj *) variables;
} Object;

#define OBJECT_DELETED	1	/* Flag to say that an object has been
				 * destroyed. */
#define DESTRUCTOR_CALLED 2	/* Flag to say that the destructor has been
				 * called. */
#define CLASS_GONE	4	/* Indicates that the class of this object has
				 * been deleted, and so the object should not
				 * attempt to remove itself from its class. */
#define ROOT_OBJECT 0x1000	/* Flag to say that this object is the root of
				 * the class hierarchy and should be treated
				 * specially during teardown. */
#define FILTER_HANDLING 0x2000	/* Flag set when the object is processing a
				 * filter; when set, filters are *not*
				 * processed on the object, preventing nasty
				 * recursive filtering problems. */

Changes to tests/oo.test.

592
593
594
595
596
597
598



















































599
600
601
602
603
604
605
    }
    # This used to crash
    [cls new] destroy
    return $result
} -cleanup {
    cls destroy
} -result {in destructor}




















































test oo-4.1 {basic test of OO functionality: export} {
    set o [oo::object new]
    set result {}
    oo::objdefine $o method Foo {} {lappend ::result Foo; return}
    lappend result [catch {$o Foo} msg] $msg
    oo::objdefine $o export Foo






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







592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
    }
    # This used to crash
    [cls new] destroy
    return $result
} -cleanup {
    cls destroy
} -result {in destructor}
test oo-3.10 {Bug 3d96b7076e: killing the object's class in a method call} -setup {
    oo::class create Super
} -body {
    # Only reliably failed in a memdebug build
    oo::class create Cls {
	superclass Super
	method mthd {} {
	    [self class] destroy
	    return ok
	}
    }
    [Cls new] mthd
} -cleanup {
    Super destroy
} -result ok
test oo-3.11 {Bug 3d96b7076e: killing the object's class in a method call} -setup {
    oo::class create Super
    oo::class create Sub {
	superclass Super
    }
} -body {
    # Only reliably failed in a memdebug build
    oo::class create Cls {
	superclass Super
	method mthd {} {
	    oo::objdefine [self] class Sub
	    Cls destroy
	    return ok
	}
    }
    [Cls new] mthd
} -cleanup {
    Super destroy
} -result ok
test oo-3.12 {Bug 3d96b7076e: killing the object's class in a method call} -setup {
    oo::class create Super
} -body {
    # Only reliably failed in a memdebug build
    oo::class create Cls {
	superclass Super
	method mthd {} {
	    [self class] destroy
	    return ok
	}
    }
    set o [Super new]
    oo::objdefine $o mixin Cls
    $o mthd
} -cleanup {
    Super destroy
} -result ok

test oo-4.1 {basic test of OO functionality: export} {
    set o [oo::object new]
    set result {}
    oo::objdefine $o method Foo {} {lappend ::result Foo; return}
    lappend result [catch {$o Foo} msg] $msg
    oo::objdefine $o export Foo