Itcl - the [incr Tcl] extension

Check-in [f21f3d75e2]
Login

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

Overview
Comment:merge trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dgp-method-type
Files: files | file ages | folders
SHA1: f21f3d75e2424b8eb7a8a55b1a00f8cc16c77cf0
User & Date: dgp 2016-08-25 15:27:22
Context
2016-08-26
12:48
merge trunk check-in: a05bc3e6d2 user: dgp tags: dgp-method-type
2016-08-25
15:27
merge trunk check-in: f21f3d75e2 user: dgp tags: dgp-method-type
15:25
Repair failed refcounting. check-in: bd2ba2b4f4 user: dgp tags: trunk
2016-07-28
12:55
merge trunk check-in: b9bee7d518 user: dgp tags: dgp-method-type
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/itclBase.c.

681
682
683
684
685
686
687







688
689
690
691
692
693
694
	if (hPtr == NULL) {
	    break;
	}
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_DeleteHashTable(&infoPtr->classTypes);








    nsPtr = Tcl_FindNamespace(interp, "::itcl::parser", NULL, 0);
    if (nsPtr != NULL) {
        Tcl_DeleteNamespace(nsPtr);
    }

    mapDict = NULL;
    ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", -1);







>
>
>
>
>
>
>







681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
	if (hPtr == NULL) {
	    break;
	}
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_DeleteHashTable(&infoPtr->classTypes);

    Tcl_DeleteHashTable(&infoPtr->procMethods);

    Tcl_DeleteHashTable(&infoPtr->objectCmds);
    Tcl_DeleteHashTable(&infoPtr->classes);
    Tcl_DeleteHashTable(&infoPtr->nameClasses);
    Tcl_DeleteHashTable(&infoPtr->namespaceClasses);

    nsPtr = Tcl_FindNamespace(interp, "::itcl::parser", NULL, 0);
    if (nsPtr != NULL) {
        Tcl_DeleteNamespace(nsPtr);
    }

    mapDict = NULL;
    ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", -1);

Changes to generic/itclClass.c.

458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
    Tcl_IncrRefCount(iclsPtr->namePtr);

    iclsPtr->fullNamePtr = Tcl_NewStringObj(classNs->fullName, -1);
    Tcl_IncrRefCount(iclsPtr->fullNamePtr);

    hPtr = Tcl_CreateHashEntry(&infoPtr->nameClasses,
            (char *)iclsPtr->fullNamePtr, &newEntry);
    if (hPtr == NULL) {
	Tcl_AppendResult(interp,
	        "ITCL: cannot create hash entry in infoPtr->nameClasses for ",
		"class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL);
	result = TCL_ERROR;
        goto errorOut;
    }
    Tcl_SetHashValue(hPtr, (ClientData)iclsPtr);


    hPtr = Tcl_CreateHashEntry(&infoPtr->namespaceClasses, (char *)classNs,
            &newEntry);
    if (hPtr == NULL) {
	Tcl_AppendResult(interp,
	        "ITCL: cannot create hash entry in infoPtr->namespaceClasses",
		" for class \"", 
		Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL);
	result = TCL_ERROR;
        goto errorOut;
    }
    Tcl_SetHashValue(hPtr, (ClientData)iclsPtr);
  if (classNs != ooNs) {
    hPtr = Tcl_CreateHashEntry(&infoPtr->namespaceClasses, (char *)ooNs,
            &newEntry);
    if (hPtr == NULL) {
	Tcl_AppendResult(interp,
	        "ITCL: cannot create hash entry in infoPtr->namespaceClasses",
		" for class \"", 
		Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL);
	result = TCL_ERROR;
        goto errorOut;
    }
    Tcl_SetHashValue(hPtr, (ClientData)iclsPtr);

    if (classNs->clientData && classNs->deleteProc) {
	(*classNs->deleteProc)(classNs->clientData);
    }
    classNs->clientData = (ClientData)iclsPtr;
    classNs->deleteProc = ItclDestroyClass2;
}

    hPtr = Tcl_CreateHashEntry(&infoPtr->classes, (char *)iclsPtr, &newEntry);
    if (hPtr == NULL) {
	Tcl_AppendResult(interp,
	        "ITCL: cannot create hash entry in infoPtr->classes",
		" for class \"", 
		Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL);
	result = TCL_ERROR;
        goto errorOut;
    }
    Tcl_SetHashValue(hPtr, (ClientData)iclsPtr);

    /*
     * now build the namespace for the common private and protected variables
     * public variables go directly to the class namespace
     */
    Tcl_DStringInit(&buffer);







<
<
<
<
<
<
<





<
<
<
<
<
<
<
<




<
<
<
<
<
<
<
<










<
<
<
<
<
<
<
<







458
459
460
461
462
463
464







465
466
467
468
469








470
471
472
473








474
475
476
477
478
479
480
481
482
483








484
485
486
487
488
489
490
    Tcl_IncrRefCount(iclsPtr->namePtr);

    iclsPtr->fullNamePtr = Tcl_NewStringObj(classNs->fullName, -1);
    Tcl_IncrRefCount(iclsPtr->fullNamePtr);

    hPtr = Tcl_CreateHashEntry(&infoPtr->nameClasses,
            (char *)iclsPtr->fullNamePtr, &newEntry);







    Tcl_SetHashValue(hPtr, (ClientData)iclsPtr);


    hPtr = Tcl_CreateHashEntry(&infoPtr->namespaceClasses, (char *)classNs,
            &newEntry);








    Tcl_SetHashValue(hPtr, (ClientData)iclsPtr);
  if (classNs != ooNs) {
    hPtr = Tcl_CreateHashEntry(&infoPtr->namespaceClasses, (char *)ooNs,
            &newEntry);








    Tcl_SetHashValue(hPtr, (ClientData)iclsPtr);

    if (classNs->clientData && classNs->deleteProc) {
	(*classNs->deleteProc)(classNs->clientData);
    }
    classNs->clientData = (ClientData)iclsPtr;
    classNs->deleteProc = ItclDestroyClass2;
}

    hPtr = Tcl_CreateHashEntry(&infoPtr->classes, (char *)iclsPtr, &newEntry);








    Tcl_SetHashValue(hPtr, (ClientData)iclsPtr);

    /*
     * now build the namespace for the common private and protected variables
     * public variables go directly to the class namespace
     */
    Tcl_DStringInit(&buffer);
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
    }
    Tcl_DeleteHashTable(&iclsPtr->options);

    /*
     *  Delete all function definitions.
     */
    FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) {
	/* functions have Itcl_ReleaseData as deleteProc in the 
	 * Tcl_Command structure of the class namespace !!
	 * but if there was an error during parsing of the class body
	 * the Tcl_Commands have not yet been built, so release here
	 */
	if (imPtr->iclsPtr->flags & ITCL_CLASS_CONSTRUCT_ERROR) {
            ItclReleaseIMF(imPtr);
	}
    }
    Tcl_DeleteHashTable(&iclsPtr->functions);

    /*
     *  Delete all delegated options.
     */
    FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) {







<
<
<
<
<
|
|
<







1120
1121
1122
1123
1124
1125
1126





1127
1128

1129
1130
1131
1132
1133
1134
1135
    }
    Tcl_DeleteHashTable(&iclsPtr->options);

    /*
     *  Delete all function definitions.
     */
    FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) {





	imPtr->iclsPtr = NULL;
        ItclReleaseIMF(imPtr);

    }
    Tcl_DeleteHashTable(&iclsPtr->functions);

    /*
     *  Delete all delegated options.
     */
    FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) {
2548
2549
2550
2551
2552
2553
2554

2555
2556
2557
2558
2559

2560
2561
2562
2563
2564
2565
2566
 */
static void
ItclDeleteFunction(
    ItclMemberFunc *imPtr)
{
    Tcl_HashEntry *hPtr;


    hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->infoPtr->procMethods,
	    (char *) imPtr->tmPtr);
    if (hPtr != NULL) {
	Tcl_DeleteHashEntry(hPtr);
    }

    hPtr = Tcl_FindHashEntry(&imPtr->infoPtr->classes, (char *)imPtr->iclsPtr);
    if (hPtr != NULL) {
	/* unlink owerself from list of class functions */
        hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->functions,
                (char *)imPtr->namePtr);
        if (hPtr != NULL) {
            Tcl_DeleteHashEntry(hPtr);







>





>







2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
 */
static void
ItclDeleteFunction(
    ItclMemberFunc *imPtr)
{
    Tcl_HashEntry *hPtr;

if (imPtr->iclsPtr) {
    hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->infoPtr->procMethods,
	    (char *) imPtr->tmPtr);
    if (hPtr != NULL) {
	Tcl_DeleteHashEntry(hPtr);
    }
}
    hPtr = Tcl_FindHashEntry(&imPtr->infoPtr->classes, (char *)imPtr->iclsPtr);
    if (hPtr != NULL) {
	/* unlink owerself from list of class functions */
        hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->functions,
                (char *)imPtr->namePtr);
        if (hPtr != NULL) {
            Tcl_DeleteHashEntry(hPtr);

Changes to generic/itclEnsemble.c.

418
419
420
421
422
423
424

425
426
427



428
429
430
431
432
433
434
    }

    if (Tcl_GetCommandInfoFromToken(ensPart->cmdPtr, infoPtr) != 1) {
        goto ensGetFail;
    }

    Itcl_DiscardInterpState(state);

    return 1;

ensGetFail:



    Itcl_RestoreInterpState(interp, state);
    return 0;
}


/*
 *----------------------------------------------------------------------







>



>
>
>







418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
    }

    if (Tcl_GetCommandInfoFromToken(ensPart->cmdPtr, infoPtr) != 1) {
        goto ensGetFail;
    }

    Itcl_DiscardInterpState(state);
    ckfree((char *)nameArgv);
    return 1;

ensGetFail:
    if (nameArgv) {
	ckfree((char *)nameArgv);
    }
    Itcl_RestoreInterpState(interp, state);
    return 0;
}


/*
 *----------------------------------------------------------------------
515
516
517
518
519
520
521

522
523
524



525
526
527
528
529
530
531

    /*
     *  Add a summary of usage information to the return buffer.
     */
    GetEnsembleUsage(interp, ensData, objPtr);

    Itcl_DiscardInterpState(state);

    return 1;

ensUsageFail:



    Itcl_RestoreInterpState(interp, state);
    return 0;
}


/*
 *----------------------------------------------------------------------







>



>
>
>







519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539

    /*
     *  Add a summary of usage information to the return buffer.
     */
    GetEnsembleUsage(interp, ensData, objPtr);

    Itcl_DiscardInterpState(state);
    ckfree((char *)nameArgv);
    return 1;

ensUsageFail:
    if (nameArgv) {
	ckfree((char *)nameArgv);
    }
    Itcl_RestoreInterpState(interp, state);
    return 0;
}


/*
 *----------------------------------------------------------------------
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
     */
    if (parentEnsData == NULL) {
	Tcl_Obj *unkObjPtr;
	ensData->cmdPtr = Tcl_CreateEnsemble(interp, ensName,
	        Tcl_GetCurrentNamespace(interp), TCL_ENSEMBLE_PREFIX);
        hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->ensembles,
                (char *)ensData->cmdPtr, &isNew);
	if (hPtr == NULL) {
	    result = TCL_ERROR;
	    goto finish;
	}
        Tcl_SetHashValue(hPtr, (ClientData)ensData);
        unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, -1);
        Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", -1);
        if (Tcl_SetEnsembleUnknownHandler(NULL, ensData->cmdPtr,







|







806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
     */
    if (parentEnsData == NULL) {
	Tcl_Obj *unkObjPtr;
	ensData->cmdPtr = Tcl_CreateEnsemble(interp, ensName,
	        Tcl_GetCurrentNamespace(interp), TCL_ENSEMBLE_PREFIX);
        hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->ensembles,
                (char *)ensData->cmdPtr, &isNew);
	if (!isNew) {
	    result = TCL_ERROR;
	    goto finish;
	}
        Tcl_SetHashValue(hPtr, (ClientData)ensData);
        unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, -1);
        Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", -1);
        if (Tcl_SetEnsembleUnknownHandler(NULL, ensData->cmdPtr,
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861

    ensPart->subEnsemblePtr = objPtr;
    Tcl_IncrRefCount(ensPart->subEnsemblePtr);
    ensPart->cmdPtr = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buffer),
            Tcl_GetCurrentNamespace(interp), TCL_ENSEMBLE_PREFIX);
    hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->ensembles,
            (char *)ensPart->cmdPtr, &isNew);
    if (hPtr == NULL) {
        result = TCL_ERROR;
        goto finish;
    }
    Tcl_SetHashValue(hPtr, (ClientData)ensData);
    unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, -1);
    Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", -1);
    if (Tcl_SetEnsembleUnknownHandler(NULL, ensPart->cmdPtr,







|







855
856
857
858
859
860
861
862
863
864
865
866
867
868
869

    ensPart->subEnsemblePtr = objPtr;
    Tcl_IncrRefCount(ensPart->subEnsemblePtr);
    ensPart->cmdPtr = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buffer),
            Tcl_GetCurrentNamespace(interp), TCL_ENSEMBLE_PREFIX);
    hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->ensembles,
            (char *)ensPart->cmdPtr, &isNew);
    if (!isNew) {
        result = TCL_ERROR;
        goto finish;
    }
    Tcl_SetHashValue(hPtr, (ClientData)ensData);
    unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, -1);
    Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", -1);
    if (Tcl_SetEnsembleUnknownHandler(NULL, ensPart->cmdPtr,

Changes to generic/itclHelpers.c.

157
158
159
160
161
162
163

164
165
166
167
168
169
170
171
172
173
174
175
176
177

178
179
180
181
182
183

184

185
186
187
188
189
190
191
	         *arglistPtrPtr = arglistPtr;
	    } else {
	        lastArglistPtr->nextPtr = arglistPtr;
	        Tcl_AppendToObj(*usagePtr, " ", 1);
	    }
	    arglistPtr->namePtr = 
	            Tcl_NewStringObj(defaultArgv[0], -1);

	    (*maxArgcPtr)++;
	    if (defaultArgc == 1) {
		(*argcPtr)++;
	        arglistPtr->defaultValuePtr = NULL;
		if ((strcmp(defaultArgv[0], "args") == 0) && (i == argc-1)) {
		    hadArgsArgument = 1;
		    (*argcPtr)--;
	            Tcl_AppendToObj(*usagePtr, "?arg arg ...?", -1);
		} else {
	            Tcl_AppendToObj(*usagePtr, defaultArgv[0], -1);
	        }
	    } else {
	        arglistPtr->defaultValuePtr = 
		        Tcl_NewStringObj(defaultArgv[1], -1);

	        Tcl_AppendToObj(*usagePtr, "?", 1);
	        Tcl_AppendToObj(*usagePtr, defaultArgv[0], -1);
	        Tcl_AppendToObj(*usagePtr, "?", 1);
	    }
            lastArglistPtr = arglistPtr;
	    i++;

        }

    }
    /*
     *  If anything went wrong, destroy whatever arguments were
     *  created and return an error.
     */
    if (result != TCL_OK) {
        ItclDeleteArgList(*arglistPtrPtr);







>














>






>

>







157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
	         *arglistPtrPtr = arglistPtr;
	    } else {
	        lastArglistPtr->nextPtr = arglistPtr;
	        Tcl_AppendToObj(*usagePtr, " ", 1);
	    }
	    arglistPtr->namePtr = 
	            Tcl_NewStringObj(defaultArgv[0], -1);
	    Tcl_IncrRefCount(arglistPtr->namePtr);
	    (*maxArgcPtr)++;
	    if (defaultArgc == 1) {
		(*argcPtr)++;
	        arglistPtr->defaultValuePtr = NULL;
		if ((strcmp(defaultArgv[0], "args") == 0) && (i == argc-1)) {
		    hadArgsArgument = 1;
		    (*argcPtr)--;
	            Tcl_AppendToObj(*usagePtr, "?arg arg ...?", -1);
		} else {
	            Tcl_AppendToObj(*usagePtr, defaultArgv[0], -1);
	        }
	    } else {
	        arglistPtr->defaultValuePtr = 
		        Tcl_NewStringObj(defaultArgv[1], -1);
		Tcl_IncrRefCount(arglistPtr->defaultValuePtr);
	        Tcl_AppendToObj(*usagePtr, "?", 1);
	        Tcl_AppendToObj(*usagePtr, defaultArgv[0], -1);
	        Tcl_AppendToObj(*usagePtr, "?", 1);
	    }
            lastArglistPtr = arglistPtr;
	    i++;
	    ckfree((char *) defaultArgv);
        }
	ckfree((char *) argv);
    }
    /*
     *  If anything went wrong, destroy whatever arguments were
     *  created and return an error.
     */
    if (result != TCL_OK) {
        ItclDeleteArgList(*arglistPtrPtr);

Changes to generic/itclInt.h.

233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
#define ITCL_CLASS_NS_IS_DESTROYED         0x4000
#define ITCL_CLASS_IS_RENAMED              0x8000
#define ITCL_CLASS_IS_FREED               0x10000
#define ITCL_CLASS_DERIVED_RELEASED       0x20000
#define ITCL_CLASS_NS_TEARDOWN            0x40000
#define ITCL_CLASS_NO_VARNS_DELETE        0x80000
#define ITCL_CLASS_SHOULD_VARNS_DELETE   0x100000
#define ITCL_CLASS_CONSTRUCT_ERROR       0x200000
#define ITCL_CLASS_DESTRUCTOR_CALLED     0x400000


typedef struct ItclClass {
    Tcl_Obj *namePtr;             /* class name */
    Tcl_Obj *fullNamePtr;         /* fully qualified class name */
    Tcl_Interp *interp;           /* interpreter that manages this info */







<







233
234
235
236
237
238
239

240
241
242
243
244
245
246
#define ITCL_CLASS_NS_IS_DESTROYED         0x4000
#define ITCL_CLASS_IS_RENAMED              0x8000
#define ITCL_CLASS_IS_FREED               0x10000
#define ITCL_CLASS_DERIVED_RELEASED       0x20000
#define ITCL_CLASS_NS_TEARDOWN            0x40000
#define ITCL_CLASS_NO_VARNS_DELETE        0x80000
#define ITCL_CLASS_SHOULD_VARNS_DELETE   0x100000

#define ITCL_CLASS_DESTRUCTOR_CALLED     0x400000


typedef struct ItclClass {
    Tcl_Obj *namePtr;             /* class name */
    Tcl_Obj *fullNamePtr;         /* fully qualified class name */
    Tcl_Interp *interp;           /* interpreter that manages this info */

Changes to generic/itclMethod.c.

371
372
373
374
375
376
377

378
379
380
381
382
383
384
     *  Make sure that the method name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    if (strstr(Tcl_GetString(namePtr),"::")) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "bad method name \"", Tcl_GetString(namePtr), "\"",
            (char*)NULL);

        return TCL_ERROR;
    }

    /*
     *  Create the method definition.
     */
    if (ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist, body,







>







371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
     *  Make sure that the method name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    if (strstr(Tcl_GetString(namePtr),"::")) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "bad method name \"", Tcl_GetString(namePtr), "\"",
            (char*)NULL);
	Tcl_DecrRefCount(namePtr);
        return TCL_ERROR;
    }

    /*
     *  Create the method definition.
     */
    if (ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist, body,
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489

    /*
     *  Add the member function to the list of functions for
     *  the class.  Make sure that a member function with the
     *  same name doesn't already exist.
     */
    hPtr = Tcl_CreateHashEntry(&iclsPtr->functions, (char *)namePtr, &newEntry);
    if (!hPtr) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\"", Tcl_GetString(namePtr), "\" already defined in class \"",
            Tcl_GetString(iclsPtr->fullNamePtr), "\"",
            (char*)NULL);
        return TCL_ERROR;
    }








|







476
477
478
479
480
481
482
483
484
485
486
487
488
489
490

    /*
     *  Add the member function to the list of functions for
     *  the class.  Make sure that a member function with the
     *  same name doesn't already exist.
     */
    hPtr = Tcl_CreateHashEntry(&iclsPtr->functions, (char *)namePtr, &newEntry);
    if (!newEntry) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\"", Tcl_GetString(namePtr), "\" already defined in class \"",
            Tcl_GetString(iclsPtr->fullNamePtr), "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

2489
2490
2491
2492
2493
2494
2495

2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508

2509
2510
2511
2512
2513
2514
2515
     *  If this is a constructor or destructor, and if it is being
     *  invoked at the appropriate time, keep track of which methods
     *  have been called.  This information is used to implicitly
     *  invoke constructors/destructors as needed.
     */
    ioPtr = callContextPtr->ioPtr;
    if (ioPtr != NULL) {

        imPtr->iclsPtr->callRefCount--;
        if (imPtr->flags & (ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR)) {
            if ((imPtr->flags & ITCL_DESTRUCTOR) && ioPtr &&
                 ioPtr->destructed) {
                Tcl_CreateHashEntry(ioPtr->destructed,
                    (char *)imPtr->iclsPtr->namePtr, &newEntry);
            }
            if ((imPtr->flags & ITCL_CONSTRUCTOR) && ioPtr &&
                 ioPtr->constructed) {
                Tcl_CreateHashEntry(ioPtr->constructed,
                    (char *)imPtr->iclsPtr->namePtr, &newEntry);
            }
        }

        ioPtr->callRefCount--;
        if (ioPtr->flags & ITCL_OBJECT_SHOULD_VARNS_DELETE) {
            ItclDeleteObjectVariablesNamespace(interp, ioPtr);
        }
    }
    
    callContextPtr->refCount--;







>













>







2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
     *  If this is a constructor or destructor, and if it is being
     *  invoked at the appropriate time, keep track of which methods
     *  have been called.  This information is used to implicitly
     *  invoke constructors/destructors as needed.
     */
    ioPtr = callContextPtr->ioPtr;
    if (ioPtr != NULL) {
      if (imPtr->iclsPtr) {
        imPtr->iclsPtr->callRefCount--;
        if (imPtr->flags & (ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR)) {
            if ((imPtr->flags & ITCL_DESTRUCTOR) && ioPtr &&
                 ioPtr->destructed) {
                Tcl_CreateHashEntry(ioPtr->destructed,
                    (char *)imPtr->iclsPtr->namePtr, &newEntry);
            }
            if ((imPtr->flags & ITCL_CONSTRUCTOR) && ioPtr &&
                 ioPtr->constructed) {
                Tcl_CreateHashEntry(ioPtr->constructed,
                    (char *)imPtr->iclsPtr->namePtr, &newEntry);
            }
        }
      }
        ioPtr->callRefCount--;
        if (ioPtr->flags & ITCL_OBJECT_SHOULD_VARNS_DELETE) {
            ItclDeleteObjectVariablesNamespace(interp, ioPtr);
        }
    }
    
    callContextPtr->refCount--;

Changes to generic/itclObject.c.

3261
3262
3263
3264
3265
3266
3267

3268
3269
3270
3271
3272
3273
3274
    if (idmPtr->asPtr != NULL) {
        Tcl_SplitList(interp, Tcl_GetString(idmPtr->asPtr),
	        &argc, &argv);
        for(j=0;j<argc;j++) {
            Tcl_ListObjAppendElement(interp, listPtr,
                    Tcl_NewStringObj(argv[j], -1));
        }

    } else {
	if (idmPtr->usingPtr != NULL) {
	    char *cp;
	    char *ep;
	    int hadDoublePercent;
            Tcl_Obj *strPtr;








>







3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
    if (idmPtr->asPtr != NULL) {
        Tcl_SplitList(interp, Tcl_GetString(idmPtr->asPtr),
	        &argc, &argv);
        for(j=0;j<argc;j++) {
            Tcl_ListObjAppendElement(interp, listPtr,
                    Tcl_NewStringObj(argv[j], -1));
        }
	ckfree((char *)argv);
    } else {
	if (idmPtr->usingPtr != NULL) {
	    char *cp;
	    char *ep;
	    int hadDoublePercent;
            Tcl_Obj *strPtr;

Changes to generic/itclParse.c.

829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
		    "\n    error while parsing class \"%s\" body %s",
		    className, Tcl_GetString(objv[2])));
	    noCleanup = 1;
	} else {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (class \"%s\" body line %s)",
		    className, Tcl_GetString(stackTrace)));
	    iclsPtr->flags |= ITCL_CLASS_CONSTRUCT_ERROR;
	}
        result = TCL_ERROR;
        goto errorReturn;
    }

    if (Itcl_FirstListElem(&iclsPtr->bases) == NULL) {
	/* No [inherit]. Use default inheritance root. */







<







829
830
831
832
833
834
835

836
837
838
839
840
841
842
		    "\n    error while parsing class \"%s\" body %s",
		    className, Tcl_GetString(objv[2])));
	    noCleanup = 1;
	} else {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (class \"%s\" body line %s)",
		    className, Tcl_GetString(stackTrace)));

	}
        result = TCL_ERROR;
        goto errorReturn;
    }

    if (Itcl_FirstListElem(&iclsPtr->bases) == NULL) {
	/* No [inherit]. Use default inheritance root. */
3300
3301
3302
3303
3304
3305
3306

3307
3308
3309
3310
3311
3312
3313
	}
        for(i = 0; i < argc; i++) {
	    Tcl_Obj *objPtr;
	    objPtr = Tcl_NewStringObj(argv[i], -1);
	    Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr,
	            &isNew);
	}

    }
    if (idmPtrPtr != NULL) {
        *idmPtrPtr = idmPtr;
    }
    ItclAddClassDelegatedFunctionDictInfo(interp, iclsPtr, idmPtr);
    return TCL_OK;
}







>







3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
	}
        for(i = 0; i < argc; i++) {
	    Tcl_Obj *objPtr;
	    objPtr = Tcl_NewStringObj(argv[i], -1);
	    Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr,
	            &isNew);
	}
	ckfree((char *) argv);
    }
    if (idmPtrPtr != NULL) {
        *idmPtrPtr = idmPtr;
    }
    ItclAddClassDelegatedFunctionDictInfo(interp, iclsPtr, idmPtr);
    return TCL_OK;
}
3810
3811
3812
3813
3814
3815
3816


3817
3818
3819
3820
3821
3822
3823
    Itcl_EventuallyFree((ClientData)idoPtr, ItclDeleteDelegatedOption);
    idoPtr->icPtr = icPtr;
    idoPtr->asPtr = targetPtr;
    if (idoPtr->asPtr != NULL) {
        Tcl_IncrRefCount(idoPtr->asPtr);
    }
    if (exceptionsPtr != NULL) {


        if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), &argc, &argv)
	        != TCL_OK) {
	    goto errorOut2;
	}
        for(i=0;i<argc;i++) {
	    Tcl_Obj *objPtr;
	    objPtr = Tcl_NewStringObj(argv[i], -1);







>
>







3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
    Itcl_EventuallyFree((ClientData)idoPtr, ItclDeleteDelegatedOption);
    idoPtr->icPtr = icPtr;
    idoPtr->asPtr = targetPtr;
    if (idoPtr->asPtr != NULL) {
        Tcl_IncrRefCount(idoPtr->asPtr);
    }
    if (exceptionsPtr != NULL) {
	ckfree((char *)argv);
	argv = NULL;
        if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), &argc, &argv)
	        != TCL_OK) {
	    goto errorOut2;
	}
        for(i=0;i<argc;i++) {
	    Tcl_Obj *objPtr;
	    objPtr = Tcl_NewStringObj(argv[i], -1);
3837
3838
3839
3840
3841
3842
3843

3844

3845
3846
3847
3848
3849
3850
3851
    Tcl_DecrRefCount(optionNamePtr);
    if (resourceNamePtr != NULL) {
        Tcl_DecrRefCount(resourceNamePtr);
    }
    if (classNamePtr != NULL) {
        Tcl_DecrRefCount(classNamePtr);
    }

    ckfree((char *)argv);

    return TCL_ERROR;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassDelegateOptionCmd()
 *







>
|
>







3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
    Tcl_DecrRefCount(optionNamePtr);
    if (resourceNamePtr != NULL) {
        Tcl_DecrRefCount(resourceNamePtr);
    }
    if (classNamePtr != NULL) {
        Tcl_DecrRefCount(classNamePtr);
    }
    if (argv) {
	ckfree((char *)argv);
    }
    return TCL_ERROR;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassDelegateOptionCmd()
 *
4062
4063
4064
4065
4066
4067
4068

4069
4070
4071
4072
4073
4074
4075
	    }
            for(i = 0; i < argc; i++) {
	        Tcl_Obj *objPtr;
	        objPtr = Tcl_NewStringObj(argv[i], -1);
	        hPtr = Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr,
	                &isNew);
	    }

        }
    }
    idmPtr->icPtr = icPtr;
    idmPtr->asPtr = targetPtr;
    if (idmPtr->asPtr != NULL) {
        Tcl_IncrRefCount(idmPtr->asPtr);
    }







>







4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
	    }
            for(i = 0; i < argc; i++) {
	        Tcl_Obj *objPtr;
	        objPtr = Tcl_NewStringObj(argv[i], -1);
	        hPtr = Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr,
	                &isNew);
	    }
	    ckfree((char *) argv);
        }
    }
    idmPtr->icPtr = icPtr;
    idmPtr->asPtr = targetPtr;
    if (idmPtr->asPtr != NULL) {
        Tcl_IncrRefCount(idmPtr->asPtr);
    }

Changes to tests/sfbugs.test.

387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
      catch {
      $obj1 m1
      ::cl1::p1
      } msg
      lappend ::test_status $msg
    }
} -result {{proc Hello World} {proc Hello World} {method Hello World} {invalid command name "cl10"}} \
  -cleanup {catch {::itcl::delete class ::cl1}}

test sfbug-259 { SF bug #257 } -setup {
    interp create slave
    load {} Itcl slave
} -cleanup {
    interp delete slave
} -body {







|







387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
      catch {
      $obj1 m1
      ::cl1::p1
      } msg
      lappend ::test_status $msg
    }
} -result {{proc Hello World} {proc Hello World} {method Hello World} {invalid command name "cl10"}} \
  -cleanup {interp delete $interp}

test sfbug-259 { SF bug #257 } -setup {
    interp create slave
    load {} Itcl slave
} -cleanup {
    interp delete slave
} -body {