Itcl - the [incr Tcl] extension

Check-in [f2fb32e38a]
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:ultimate segfault-fix of [1dc2d851eb], mod-case of "sfbug-254.3" - create class, but now with other base (inheritance that was removed with oo-subsystem), all tests passed now; note Tcl_GetClassAsObject(infoPtr->clazzClassPtr) can return other object-instance of "deleted" root class, that is still valid for some reasons.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | bug-1dc2d851eb
Files: files | file ages | folders
SHA3-256:f2fb32e38af3901d5679a24d12e1e632f1d203a709f6c4e4e8d9212f76954d96
User & Date: sebres 2019-02-08 23:38:52
Context
2019-02-08
23:51
merge bug-1dc2d851eb: fixes several segfault, see [1dc2d851eb] check-in: e0601c3371 user: sebres tags: trunk
23:38
ultimate segfault-fix of [1dc2d851eb], mod-case of "sfbug-254.3" - create class, but now with other base (inheritance that was removed with oo-subsystem), all tests passed now; note Tcl_GetClassAsObject(infoPtr->clazzClassPtr) can return other object-instance of "deleted" root class, that is still valid for some reasons. Closed-Leaf check-in: f2fb32e38a user: sebres tags: bug-1dc2d851eb
23:13
extend test case illustrating still one segfault, still create class, but now with other base (inheritance that was removed with oo-subsystem) check-in: 1c9c7d5c9e user: sebres tags: bug-1dc2d851eb
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/itclBase.c.

384
385
386
387
388
389
390

391
392
393
394
395
396
397
    }

    /* work around for SF bug #254 needed because of problem in TclOO 1.0.2 !! */
    if (Tcl_PkgPresent(interp, "TclOO", "1.0.2", 1) != NULL) {
	Itcl_IncrObjectRefCount(clazzObjectPtr);
    }


    infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(clazzObjectPtr);

    /*
     *  Initialize the ensemble package first, since we need this
     *  for other parts of [incr Tcl].
     */








>







384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
    }

    /* work around for SF bug #254 needed because of problem in TclOO 1.0.2 !! */
    if (Tcl_PkgPresent(interp, "TclOO", "1.0.2", 1) != NULL) {
	Itcl_IncrObjectRefCount(clazzObjectPtr);
    }

    infoPtr->clazzObjectPtr = clazzObjectPtr;
    infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(clazzObjectPtr);

    /*
     *  Initialize the ensemble package first, since we need this
     *  for other parts of [incr Tcl].
     */

Changes to generic/itclClass.c.

244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
    Tcl_HashEntry *hPtr;
    void *callbackPtr;
    int result;
    int newEntry;
    ItclResolveInfo *resolveInfoPtr;
    Tcl_Obj *cmdNamePtr;

    if (!infoPtr->clazzClassPtr 
	|| !(oPtr = Tcl_GetClassAsObject(infoPtr->clazzClassPtr))
	|| Tcl_ObjectDeleted(oPtr)
    ) {
	Tcl_AppendResult(interp, "oo-subsystem is deleted", NULL);
	return TCL_ERROR;
    }

    /*
     * check for an empty class name to avoid a crash







|
<
|







244
245
246
247
248
249
250
251

252
253
254
255
256
257
258
259
    Tcl_HashEntry *hPtr;
    void *callbackPtr;
    int result;
    int newEntry;
    ItclResolveInfo *resolveInfoPtr;
    Tcl_Obj *cmdNamePtr;

    if (!infoPtr->clazzClassPtr

	|| Tcl_ObjectDeleted(infoPtr->clazzObjectPtr)
    ) {
	Tcl_AppendResult(interp, "oo-subsystem is deleted", NULL);
	return TCL_ERROR;
    }

    /*
     * check for an empty class name to avoid a crash

Changes to generic/itclInt.h.

165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
				     * otherwise NULL */
    Tcl_ObjectMetadataType *class_meta_type;
                                    /* type for getting the Itcl class info
                                     * from a TclOO Tcl_Object */
    const Tcl_ObjectMetadataType *object_meta_type;
                                    /* type for getting the Itcl object info
                                     * from a TclOO Tcl_Object */
    Tcl_Object unused1;             /* the root object of Itcl */
    Tcl_Class clazzClassPtr;        /* the root class of Itcl */
    struct EnsembleInfo *ensembleInfo;
    struct ItclClass *currContextIclsPtr;
                                    /* context class for delegated option
                                     * handling */
    int currClassFlags;             /* flags for the class just in creation */
    int buildingWidget;             /* set if in construction of a widget */







|







165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
				     * otherwise NULL */
    Tcl_ObjectMetadataType *class_meta_type;
                                    /* type for getting the Itcl class info
                                     * from a TclOO Tcl_Object */
    const Tcl_ObjectMetadataType *object_meta_type;
                                    /* type for getting the Itcl object info
                                     * from a TclOO Tcl_Object */
    Tcl_Object clazzObjectPtr;      /* the root object of Itcl */
    Tcl_Class clazzClassPtr;        /* the root class of Itcl */
    struct EnsembleInfo *ensembleInfo;
    struct ItclClass *currContextIclsPtr;
                                    /* context class for delegated option
                                     * handling */
    int currClassFlags;             /* flags for the class just in creation */
    int buildingWidget;             /* set if in construction of a widget */

Changes to tests/sfbugs.test.

336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
    if {[catch {
      $interp eval {
        ::itcl::class ::test2 {inherit ::test}
      }
    } msg]} {
      lappend ::test_status $msg
    }
} -result {{::test class created} {::oo::class destroy worked} {invalid command name "::test"}} \
  -cleanup {interp delete $interp}

test sfbug-255 { SF bug #255
} -body {
    set ::test_status ""

    proc ::sfbug_255_do_uplevel { body } {







|







336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
    if {[catch {
      $interp eval {
        ::itcl::class ::test2 {inherit ::test}
      }
    } msg]} {
      lappend ::test_status $msg
    }
} -result {{::test class created} {::oo::class destroy worked} {invalid command name "::test"} {oo-subsystem is deleted}} \
  -cleanup {interp delete $interp}

test sfbug-255 { SF bug #255
} -body {
    set ::test_status ""

    proc ::sfbug_255_do_uplevel { body } {