Itcl - the [incr Tcl] extension

Check-in [e0601c3371]
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 bug-1dc2d851eb: fixes several segfault, see [1dc2d851eb]
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: e0601c3371e085630a50a16beb30726447a2318b066493622bcd76e2fdad91fb
User & Date: sebres 2019-02-08 23:51:16
Context
2019-02-09
20:22
code review: revert clazzObjectPtr back to unused, remove increment workaround for OO 1.0.2 (thisPtr of clazz is removed with last ref to engine, no matter how many references still exist). check-in: b8e09f7f17 user: sebres tags: trunk
2019-02-08
23:59
merge trunk, no segfaults anymore (applied stashes, looks good, so WiP) check-in: 2b6eae425d user: sebres tags: sebres-memopt-perf-branch
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
17:59
fixes [87a89c9a927db943]: apply "-load" test-option for child interpreter in tests "sfbug-254" and "sfbug-257" (provides library-path to pkgIndex or loads Itcl directly). check-in: 0155e66402 user: sebres tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/itclBase.c.

208
209
210
211
212
213
214

215
216
217
218
219
220
221
...
338
339
340
341
342
343
344
345
346
347
348





349
350
351
352
353
354
355
...
378
379
380
381
382
383
384

385
386
387
388
389
390
391
...
732
733
734
735
736
737
738

739


740

741

742


743

744
745


746
747
748
749
750
751
752
    Tcl_Namespace *itclNs;
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr;
    const char * ret;
    char *res_option;
    int opt;
    int isNew;

    Tcl_Object clazzObjectPtr, root;
    Tcl_Obj *objPtr, *resPtr;

    if (Tcl_InitStubs(interp, "8.6", 0) == NULL) {
        return TCL_ERROR;
    }

................................................................................
    Itcl_PreserveData((ClientData)infoPtr);

#ifdef NEW_PROTO_RESOLVER
    ItclVarsAndCommandResolveInit(interp);
#endif

    objPtr = Tcl_NewStringObj("::oo::class", -1);
    root = Tcl_NewObjectInstance(interp, Tcl_GetObjectAsClass(
	    Tcl_GetObjectFromObj(interp, objPtr)), "::itcl::Root",
	    NULL, 0, NULL, 0);
    Tcl_DecrRefCount(objPtr);






    Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
	    Tcl_NewStringObj("unknown", -1), 0, &itclRootMethodType,
	    ItclUnknownGuts);
    Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
	    Tcl_NewStringObj("ItclConstructBase", -1), 0,
	    &itclRootMethodType, ItclConstructGuts);
................................................................................
    }

    /* 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].
     */

................................................................................
	    Tcl_SetEnsembleMappingDict(interp, cmdPtr, mapDict);
        }
    }
    /* FIXME have to figure out why the refCount of
     * ::itcl::builtin::Info
     * and ::itcl::builtin::Info::vars and vars is 2 here !! */
    /* seems to be as the tclOO commands are not yet deleted ?? */

    Tcl_DecrRefCount(infoPtr->infoVars3Ptr);


    Tcl_DecrRefCount(infoPtr->infoVars4Ptr);

    if (checkMemoryLeaks) {

        Tcl_DecrRefCount(infoPtr->infoVars3Ptr);


        Tcl_DecrRefCount(infoPtr->infoVars4Ptr);

    /* see comment above */
    }



    Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr);

    Tcl_EvalEx(infoPtr->interp,
            "::oo::define ::itcl::clazz deletemethod unknown", -1, 0);

    /* first have to look for the remaining memory leaks, then remove the next ifdef */






>







 







|
|
|
|
>
>
>
>
>







 







>







 







>
|
>
>
|
>

>
|
>
>
|
>


>
>







208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
...
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
...
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
...
739
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
767
768
769
    Tcl_Namespace *itclNs;
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr;
    const char * ret;
    char *res_option;
    int opt;
    int isNew;
    Tcl_Class tclCls;
    Tcl_Object clazzObjectPtr, root;
    Tcl_Obj *objPtr, *resPtr;

    if (Tcl_InitStubs(interp, "8.6", 0) == NULL) {
        return TCL_ERROR;
    }

................................................................................
    Itcl_PreserveData((ClientData)infoPtr);

#ifdef NEW_PROTO_RESOLVER
    ItclVarsAndCommandResolveInit(interp);
#endif

    objPtr = Tcl_NewStringObj("::oo::class", -1);
    Tcl_IncrRefCount(objPtr);
    clazzObjectPtr = Tcl_GetObjectFromObj(interp, objPtr);
    if (!clazzObjectPtr || !(tclCls = Tcl_GetObjectAsClass(clazzObjectPtr))) {
	Tcl_DecrRefCount(objPtr);
        return TCL_ERROR;
    }
    Tcl_DecrRefCount(objPtr);
    root = Tcl_NewObjectInstance(interp, tclCls, "::itcl::Root",
	    NULL, 0, NULL, 0);

    Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
	    Tcl_NewStringObj("unknown", -1), 0, &itclRootMethodType,
	    ItclUnknownGuts);
    Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
	    Tcl_NewStringObj("ItclConstructBase", -1), 0,
	    &itclRootMethodType, ItclConstructGuts);
................................................................................
    }

    /* 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].
     */

................................................................................
	    Tcl_SetEnsembleMappingDict(interp, cmdPtr, mapDict);
        }
    }
    /* FIXME have to figure out why the refCount of
     * ::itcl::builtin::Info
     * and ::itcl::builtin::Info::vars and vars is 2 here !! */
    /* seems to be as the tclOO commands are not yet deleted ?? */
    if (infoPtr->infoVars3Ptr) {
	Tcl_DecrRefCount(infoPtr->infoVars3Ptr);
    }
    if (infoPtr->infoVars4Ptr) {
	Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
    }
    if (checkMemoryLeaks) {
        if (infoPtr->infoVars3Ptr) {
	    Tcl_DecrRefCount(infoPtr->infoVars3Ptr);
	}
	if (infoPtr->infoVars4Ptr) {
	    Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
	}
    /* see comment above */
    }
    infoPtr->infoVars3Ptr = NULL;
    infoPtr->infoVars4Ptr = NULL;

    Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr);

    Tcl_EvalEx(infoPtr->interp,
            "::oo::define ::itcl::clazz deletemethod unknown", -1, 0);

    /* first have to look for the remaining memory leaks, then remove the next ifdef */

Changes to generic/itclClass.c.

243
244
245
246
247
248
249







250
251
252
253
254
255
256
    ItclVariable *ivPtr;
    Tcl_HashEntry *hPtr;
    void *callbackPtr;
    int result;
    int newEntry;
    ItclResolveInfo *resolveInfoPtr;
    Tcl_Obj *cmdNamePtr;








    /*
     * check for an empty class name to avoid a crash
     */
    if (strlen(path) == 0) {
	Tcl_AppendResult(interp, "invalid class name \"\"", NULL);
        return TCL_ERROR;






>
>
>
>
>
>
>







243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
    ItclVariable *ivPtr;
    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
     */
    if (strlen(path) == 0) {
	Tcl_AppendResult(interp, "invalid class name \"\"", NULL);
        return TCL_ERROR;

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.

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
       }
    }

    [foo #auto] kerplunk hello world
} -result {{foo0 kerplunk hello world} {foo0 kerplunk hello world} {foo0 kerplunk hello world}} \
  -cleanup {::itcl::delete class foo}

test sfbug-254 { SF bug #254
} -body {
    set interp [interp create]









































    $interp eval [::tcltest::loadScript]
    $interp eval {
      package require itcl



      set ::test_status ""

      oo::class destroy

      lappend ::test_status "::oo::class destroy worked"



    }
} -result {{::oo::class destroy worked}} \











  -cleanup { }

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

    proc ::sfbug_255_do_uplevel { body } {
        uplevel 1 $body






|


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




>
>
|
>

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







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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
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
347
348
349
350
351
       }
    }

    [foo #auto] kerplunk hello world
} -result {{foo0 kerplunk hello world} {foo0 kerplunk hello world} {foo0 kerplunk hello world}} \
  -cleanup {::itcl::delete class foo}

test sfbug-254.1 { SF bug #254 + bug [1dc2d851eb]
} -body {
    set interp [interp create]
    set ::test_status ""
    $interp eval {
      oo::class destroy
    }
    lappend ::test_status "::oo::class destroy worked"
    if {[catch {
      $interp eval [::tcltest::loadScript]
      $interp eval {
        package require itcl
      }
    } msg]} {
      lappend ::test_status $msg
    }
} -result {{::oo::class destroy worked} {::oo::class does not refer to an object}} \
  -cleanup {interp delete $interp}

test sfbug-254.2 { SF bug #254 + bug [1dc2d851eb]
} -body {
    set interp [interp create]
    set ::test_status ""
    $interp eval [::tcltest::loadScript]
    $interp eval {
      package require itcl

      oo::class destroy
    }
    lappend ::test_status "::oo::class destroy worked"
    if {[catch {
      $interp eval {
        ::itcl::class ::test {}
      }
    } msg]} {
      lappend ::test_status $msg
    }
} -result {{::oo::class destroy worked} {oo-subsystem is deleted}} \
  -cleanup {interp delete $interp}

test sfbug-254.3 { delete oo-subsystem should remove all classes + summary of bug [1dc2d851eb]
} -body {
    set interp [interp create]
    set ::test_status ""
    $interp eval [::tcltest::loadScript]
    $interp eval {
      package require itcl

      ::itcl::class ::test {}
    }
    lappend ::test_status "::test class created"
    $interp eval {
      oo::class destroy
    }
    lappend ::test_status "::oo::class destroy worked"
    if {[catch {
      $interp eval {
        ::test x
      }

    } msg]} {
      lappend ::test_status $msg
    }
    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 } {
        uplevel 1 $body