Tcl Source Code

Check-in [93c437ef37]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

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

Overview
Comment:Fix for issue [6cf568a21b]: Tcl_Eval() causes new segfault (TclOO object creation by qualified name).
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-branch
Files: files | file ages | folders
SHA3-256:93c437ef370480b3c80fb63726a3e460467df377eb4af0a36e5a75f26453f281
User & Date: pooryorick 2017-11-28 23:33:14
References
2017-11-29
11:27 Ticket [16fe1b5807] namespace ensemble command named ":" is mistakenly given the empty string as its name status still Pending with 3 other changes artifact: 77e7a8d1a0 user: pooryorick
01:56 Ticket [6cf568a21b] Tcl_Eval() causes new segfault status still Open with 4 other changes artifact: 50516da155 user: hypnotoad
Context
2018-02-15
08:53
Fix for issue [6cf568a21b]: Tcl_Eval() causes new segfault (TclOO object creation by qualified name)... check-in: a5d05b97be user: pooryorick tags: pyk-backport-to-8-6
2017-11-29
11:05
merge core-8-6-branch check-in: 8976a447aa user: jan.nijtmans tags: core-8-branch
08:41
merge core-8-branch check-in: 32734bbfaf user: jan.nijtmans tags: tip-389
01:59
Pulling changes from core-8-branch check-in: 3598570130 user: hypnotoad tags: core_zip_vfs
2017-11-28
23:33
Fix for issue [6cf568a21b]: Tcl_Eval() causes new segfault (TclOO object creation by qualified name)... check-in: 93c437ef37 user: pooryorick tags: core-8-branch
15:43
Minor refactoring of TclOO object reference count booking during object creation. check-in: a2bfd20d2c user: pooryorick tags: core-8-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOO.c.

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
...
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
...
548
549
550
551
552
553
554


555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
...
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
....
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
....
1723
1724
1725
1726
1727
1728
1729

1730
1731




1732




1733
1734
1735
1736
1737
1738





1739
1740
1741
1742
1743

1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764

/*
 * Function declarations for things defined in this file.
 */

static Class *		AllocClass(Tcl_Interp *interp, Object *useThisObj);
static Object *		AllocObject(Tcl_Interp *interp, const char *nameStr,
			    const char *nsNameStr);
static void		ClearMixins(Class *clsPtr);
static void		ClearSuperclasses(Class *clsPtr);
static int		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
			    Method *mPtr, Tcl_Obj *namePtr,
			    Method **newMPtrPtr);
static int		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
			    Method *mPtr, Tcl_Obj *namePtr);
................................................................................

    /*
     * Create the objects at the core of the object system. These need to be
     * spliced manually.
     */

    fPtr->objectCls = AllocClass(interp,
	    AllocObject(interp, "::oo::object", NULL));
    fPtr->classCls = AllocClass(interp,
	    AllocObject(interp, "::oo::class", NULL));
    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
    fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
    fPtr->objectCls->flags |= ROOT_OBJECT;
    fPtr->objectCls->superclasses.num = 0;
    ckfree(fPtr->objectCls->superclasses.list);
    fPtr->objectCls->superclasses.list = NULL;
    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
................................................................................
AllocObject(
    Tcl_Interp *interp,		/* Interpreter within which to create the
				 * object. */
    const char *nameStr,	/* The name of the object to create, or NULL
				 * if the OO system should pick the object
				 * name itself (equal to the namespace
				 * name). */


    const char *nsNameStr)	/* The name of the namespace to create, or
				 * NULL if the OO system should pick a unique
				 * name itself. If this is non-NULL but names
				 * a namespace that already exists, the effect
				 * will be the same as if this was NULL. */
{
    Foundation *fPtr = GetFoundation(interp);
    Object *oPtr;
    Command *cmdPtr;
    CommandTrace *tracePtr;
    Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
    Tcl_Namespace *inNsPtr;
    int creationEpoch, ignored;
    const char *simpleName;

    oPtr = ckalloc(sizeof(Object));
    memset(oPtr, 0, sizeof(Object));

    /*
     * Every object has a namespace; make one. Note that this also normally
     * computes the creation epoch value for the object, a sequence number
................................................................................

    /*
     * Finally, create the object commands and initialize the trace on the
     * public command (so that the object structures are deleted when the
     * command is deleted).
     */

    if (nameStr) {
	inNsPtr = TclGetCurrentNamespace(interp);
    } else {
	nameStr = oPtr->namespacePtr->name;
	inNsPtr = oPtr->namespacePtr;
    }
    
    TclGetNamespaceForQualName(interp, nameStr, (Namespace *) inNsPtr, 0,
	    &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);

    oPtr->command = TclCreateObjCommandInNs(interp, simpleName,
	(Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);

    /*
     * Add the NRE command and trace directly. While this breaks a number of
     * abstractions, it is faster and we're inside Tcl here so we're allowed.
     */

................................................................................

    /*
     * Make an object if we haven't been given one.
     */

    memset(clsPtr, 0, sizeof(Class));
    if (useThisObj == NULL) {
	clsPtr->thisPtr = AllocObject(interp, NULL, NULL);
    } else {
	clsPtr->thisPtr = useThisObj;
    }

    /*
     * Configure the namespace path for the class's object.
     */
................................................................................
Object *
TclNewObjectInstanceCommon(
    Tcl_Interp *interp,
    Class *classPtr,
    const char *nameStr,
    const char *nsNameStr)
{

    Foundation *fPtr = GetFoundation(interp);
    Object *oPtr;









    /*
     * Disallow creation of an object over an existing command.
     */

    if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
	    TCL_NAMESPACE_ONLY)) {





	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"can't create object \"%s\": command already exists with"
		" that name", nameStr));
	Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
	return NULL;

    }

    /*
     * Create the object.
     */

    /*
     * The command for the object could have the same name as the command
     * associated with classPtr, so protect the structure from deallocation
     * here.
     */
    AddRef(classPtr);

    oPtr = AllocObject(interp, nameStr, nsNameStr);
    DelRef(classPtr);
    oPtr->selfCls = classPtr;
    TclOOAddToInstances(oPtr, classPtr);

    /*
     * Check to see if we're really creating a class. If so, allocate the
     * class structure as well.







|







 







|

|







 







>
>










<
<

<







 







|
<
<

|

<
<
<
<
|







 







|







 







>


>
>
>
>

>
>
>
>
|
|
|

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













|







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
...
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
...
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566


567

568
569
570
571
572
573
574
...
648
649
650
651
652
653
654
655


656
657
658




659
660
661
662
663
664
665
666
....
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
....
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738


1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770

/*
 * Function declarations for things defined in this file.
 */

static Class *		AllocClass(Tcl_Interp *interp, Object *useThisObj);
static Object *		AllocObject(Tcl_Interp *interp, const char *nameStr,
			    Namespace *nsPtr, const char *nsNameStr);
static void		ClearMixins(Class *clsPtr);
static void		ClearSuperclasses(Class *clsPtr);
static int		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
			    Method *mPtr, Tcl_Obj *namePtr,
			    Method **newMPtrPtr);
static int		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
			    Method *mPtr, Tcl_Obj *namePtr);
................................................................................

    /*
     * Create the objects at the core of the object system. These need to be
     * spliced manually.
     */

    fPtr->objectCls = AllocClass(interp,
	    AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
    fPtr->classCls = AllocClass(interp,
	    AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
    fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
    fPtr->objectCls->flags |= ROOT_OBJECT;
    fPtr->objectCls->superclasses.num = 0;
    ckfree(fPtr->objectCls->superclasses.list);
    fPtr->objectCls->superclasses.list = NULL;
    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
................................................................................
AllocObject(
    Tcl_Interp *interp,		/* Interpreter within which to create the
				 * object. */
    const char *nameStr,	/* The name of the object to create, or NULL
				 * if the OO system should pick the object
				 * name itself (equal to the namespace
				 * name). */
    Namespace *nsPtr,		/* The namespace to create the object in,
				   or NULL if *nameStr is NULL */
    const char *nsNameStr)	/* The name of the namespace to create, or
				 * NULL if the OO system should pick a unique
				 * name itself. If this is non-NULL but names
				 * a namespace that already exists, the effect
				 * will be the same as if this was NULL. */
{
    Foundation *fPtr = GetFoundation(interp);
    Object *oPtr;
    Command *cmdPtr;
    CommandTrace *tracePtr;


    int creationEpoch, ignored;


    oPtr = ckalloc(sizeof(Object));
    memset(oPtr, 0, sizeof(Object));

    /*
     * Every object has a namespace; make one. Note that this also normally
     * computes the creation epoch value for the object, a sequence number
................................................................................

    /*
     * Finally, create the object commands and initialize the trace on the
     * public command (so that the object structures are deleted when the
     * command is deleted).
     */

    if (!nameStr) {


	nameStr = oPtr->namespacePtr->name;
	nsPtr = (Namespace *)oPtr->namespacePtr;
    }




    oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
	(Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);

    /*
     * Add the NRE command and trace directly. While this breaks a number of
     * abstractions, it is faster and we're inside Tcl here so we're allowed.
     */

................................................................................

    /*
     * Make an object if we haven't been given one.
     */

    memset(clsPtr, 0, sizeof(Class));
    if (useThisObj == NULL) {
	clsPtr->thisPtr = AllocObject(interp, NULL, NULL, NULL);
    } else {
	clsPtr->thisPtr = useThisObj;
    }

    /*
     * Configure the namespace path for the class's object.
     */
................................................................................
Object *
TclNewObjectInstanceCommon(
    Tcl_Interp *interp,
    Class *classPtr,
    const char *nameStr,
    const char *nsNameStr)
{
    Tcl_HashEntry *hPtr;
    Foundation *fPtr = GetFoundation(interp);
    Object *oPtr;
    const char *simpleName = NULL;
    Namespace *nsPtr = NULL, *dummy,
	*inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
    int isNew;

    if (nameStr) {
	TclGetNamespaceForQualName(interp, nameStr, inNsPtr, TCL_CREATE_NS_IF_UNKNOWN,
		&nsPtr, &dummy, &dummy, &simpleName);

	/*
	 * Disallow creation of an object over an existing command.
	 */



	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew);
	if (isNew) {
	    /* Just kidding */
	    Tcl_DeleteHashEntry(hPtr);
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "can't create object \"%s\": command already exists with"
		    " that name", nameStr));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
	    return NULL;
	}
    }

    /*
     * Create the object.
     */

    /*
     * The command for the object could have the same name as the command
     * associated with classPtr, so protect the structure from deallocation
     * here.
     */
    AddRef(classPtr);

    oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
    DelRef(classPtr);
    oPtr->selfCls = classPtr;
    TclOOAddToInstances(oPtr, classPtr);

    /*
     * Check to see if we're really creating a class. If so, allocate the
     * class structure as well.

Changes to tests/oo.test.

124
125
126
127
128
129
130



131
132
133
134
135
136
137
    set errorInfo
} "wrong # args: should be \"oo::define oo::object method name args body\"
    while executing
\"oo::define oo::object method missingArgs\""
test oo-1.4 {basic test of OO functionality} -body {
    oo::object create {}
} -returnCodes 1 -result {object name must not be empty}



test oo-1.5 {basic test of OO functionality} -body {
    oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
test oo-1.5.1 {basic test of OO functionality} -setup {
    oo::object create aninstance
} -returnCodes error -body {
    aninstance







>
>
>







124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
    set errorInfo
} "wrong # args: should be \"oo::define oo::object method name args body\"
    while executing
\"oo::define oo::object method missingArgs\""
test oo-1.4 {basic test of OO functionality} -body {
    oo::object create {}
} -returnCodes 1 -result {object name must not be empty}
test oo-1.4.1 {fully-qualified nested name} -body {
    oo::object create ::one::two::three 
} -result {::one::two::three}
test oo-1.5 {basic test of OO functionality} -body {
    oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
test oo-1.5.1 {basic test of OO functionality} -setup {
    oo::object create aninstance
} -returnCodes error -body {
    aninstance