Itk - the [incr Tk] extension

Check-in [b8982b983a]
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:Debugging work in progress....
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dgp-method-type
Files: files | file ages | folders
SHA1: b8982b983ae30f370c40c30252d4b352e984e133
User & Date: dgp 2015-08-03 04:20:09
Context
2015-08-03
21:01
Much more progress. check-in: ed739315fd user: dgp tags: dgp-method-type
04:20
Debugging work in progress.... check-in: b8982b983a user: dgp tags: dgp-method-type
2015-07-29
16:45
merge trunk check-in: 482c48daf2 user: dgp tags: dgp-method-type
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/itkArchBase.c.

309
310
311
312
313
314
315

316
317
318
319
320
321
322
...
506
507
508
509
510
511
512
513
514


515
516
517
518

519
520
521
522
523
524
525
...
821
822
823
824
825
826
827



828
829
830
831

832
833
834
835
836

837
838
839
840
841
842
843
....
1717
1718
1719
1720
1721
1722
1723


1724
1725
1726
1727
1728
1729
1730
....
1790
1791
1792
1793
1794
1795
1796


1797
1798
1799
1800
1801
1802
1803
....
1822
1823
1824
1825
1826
1827
1828


1829
1830
1831
1832
1833
1834
1835
....
2171
2172
2173
2174
2175
2176
2177













2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189


2190
2191


2192
2193

2194
2195
2196
2197
2198
2199
2200
    Itcl_SetCallFrameResolver(interp, contextClass->resolvePtr);
    infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL);
    uplevelFramePtr = Itcl_GetUplevelCallFrame(interp, 1);
    oldFramePtr = Itcl_ActivateCallFrame(interp, uplevelFramePtr);
#endif
    result = Tcl_EvalObjEx(interp, objv[2], 0);
    if (result != TCL_OK) {

        goto compFail;
    }

    /*
     *  Take the result from the widget creation commands as the
     *  path name for the new component.  Make a local copy of
     *  this, since the interpreter will get used in the mean time.
................................................................................
    if (objc != 4) {
        objPtr = Tcl_NewStringObj("usual", -1);
        Tcl_IncrRefCount(objPtr);
    } else {
        objPtr = objv[3];
    }

    result = Itcl_PushCallFrame(interp, &frame, parserNs,
            /* isProcCallFrame */ 0);



    if (result == TCL_OK) {
        result = Tcl_EvalObj(interp, objPtr);
        Itcl_PopCallFrame(interp);

    }

    if (objc != 4) {
        Tcl_DecrRefCount(objPtr);
    }
    if (result != TCL_OK) {
        goto compFail;
................................................................................
        cmdlinePtr = Itk_CreateConfigCmdline(interp,
            mergeInfo->archComp->accessCmd, token);

        optPart = Itk_CreateOptionPart(interp, (ClientData)cmdlinePtr,
            Itk_PropagateOption, Itk_DeleteConfigCmdline,
            (ClientData)mergeInfo->archComp);




        result = Itk_AddOptionPart(interp, mergeInfo->archInfo,
            opt->switchName, opt->resName, opt->resClass,
            opt->init, opt->value, optPart, &archOpt);


        if (result == TCL_OK) {
            opt->integrated = archOpt;
            opt->optPart    = optPart;
        } else {
            Itk_DelOptionPart(optPart);

            result = TCL_ERROR;
            break;
        }
    }
    return result;
}

................................................................................
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "unknown option \"", name, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }
    archOpt = (ArchOption*)Tcl_GetHashValue(entry);



    if (!Tcl_SetVar2(interp, "itk_option", archOpt->switchName,
	    (const char *)value, 0)) {
        Itk_ArchOptAccessError(interp, info, archOpt);
        return TCL_ERROR;
    }
    return TCL_OK;
}
................................................................................
    } else {
        lastval = NULL;
    }

    /*
     *  Update the "itk_option" array with the new setting.
     */


    if (!Tcl_SetVar2(interp, "itk_option", archOpt->switchName, value, 0)) {
        Itk_ArchOptAccessError(interp, info, archOpt);
        result = TCL_ERROR;
        goto configDone;
    }

    /*
................................................................................
     *  If the option configuration failed, then set the option
     *  back to its previous settings.  Scan back through all of
     *  the option parts and sync them up with the old value.
     */
    if (result == TCL_ERROR) {
        istate = Itcl_SaveInterpState(interp, result);



        Tcl_SetVar2(interp, "itk_option", archOpt->switchName, lastval, 0);

        part = Itcl_FirstListElem(&archOpt->parts);
        while (part) {
            optPart = (ArchOptionPart*)Itcl_GetListValue(part);
            (*optPart->configProc)(interp, info->itclObj,
                optPart->clientData, lastval);
................................................................................
        (c == 's' && strcmp(archOpt->switchName,"-screen") == 0) ||
        (c == 'v' && strcmp(archOpt->switchName,"-visual") == 0)) {
        ival = currVal;
    } else {
        ival = init;
    }














    /*
     *  Set the initial value in the itk_option array.
     *  Since this might be called from the itk::option-parser
     *  namespace, reinstall the object context.
     */
    result = Itcl_PushCallFrame(interp, &frame, info->itclObj->iclsPtr->nsPtr, /*isProcCallFrame*/0);

    if (result == TCL_OK) {
	/*
	 * Casting away CONST of ival only to satisfy Tcl 8.3 and
	 * earlier headers.
	 */


        Tcl_SetVar2(interp, "itk_option", archOpt->switchName,
            (char *)((ival) ? ival : ""), 0);


    Itcl_PopCallFrame(interp);
    }


    if (ival) {
        archOpt->init = (char*)ckalloc((unsigned)(strlen(ival)+1));
        strcpy(archOpt->init, ival);
    }
}
 






>







 







|
|
>
>



|
>







 







>
>
>




>





>







 







>
>







 







>
>







 







>
>







 







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












>
>
|

>
>


>







309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
...
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
...
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
....
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
....
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
....
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
....
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
    Itcl_SetCallFrameResolver(interp, contextClass->resolvePtr);
    infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL);
    uplevelFramePtr = Itcl_GetUplevelCallFrame(interp, 1);
    oldFramePtr = Itcl_ActivateCallFrame(interp, uplevelFramePtr);
#endif
    result = Tcl_EvalObjEx(interp, objv[2], 0);
    if (result != TCL_OK) {
fprintf(stdout, "FAIL '%s'!\n", Tcl_GetString(objv[2])); fflush(stdout);
        goto compFail;
    }

    /*
     *  Take the result from the widget creation commands as the
     *  path name for the new component.  Make a local copy of
     *  this, since the interpreter will get used in the mean time.
................................................................................
    if (objc != 4) {
        objPtr = Tcl_NewStringObj("usual", -1);
        Tcl_IncrRefCount(objPtr);
    } else {
        objPtr = objv[3];
    }

//    result = Itcl_PushCallFrame(interp, &frame, parserNs,
 //           /* isProcCallFrame */ 0);

    Tcl_Import(interp, NULL, "::itk::option-parser::*", 1);

    if (result == TCL_OK) {
        result = Tcl_EvalObj(interp, objPtr);
  //      Itcl_PopCallFrame(interp);
	Tcl_ForgetImport(interp, NULL, "::itk::option-parser::*");
    }

    if (objc != 4) {
        Tcl_DecrRefCount(objPtr);
    }
    if (result != TCL_OK) {
        goto compFail;
................................................................................
        cmdlinePtr = Itk_CreateConfigCmdline(interp,
            mergeInfo->archComp->accessCmd, token);

        optPart = Itk_CreateOptionPart(interp, (ClientData)cmdlinePtr,
            Itk_PropagateOption, Itk_DeleteConfigCmdline,
            (ClientData)mergeInfo->archComp);

fprintf(stdout, "KEEP 4 '%s' '%s'\n", token,
Tcl_GetCurrentNamespace(interp)->fullName); fflush(stdout);

        result = Itk_AddOptionPart(interp, mergeInfo->archInfo,
            opt->switchName, opt->resName, opt->resClass,
            opt->init, opt->value, optPart, &archOpt);

fprintf(stdout, "KEEP 5 '%s'\n", token); fflush(stdout);
        if (result == TCL_OK) {
            opt->integrated = archOpt;
            opt->optPart    = optPart;
        } else {
            Itk_DelOptionPart(optPart);
fprintf(stdout, "KEEP ERROR '%s'\n", token); fflush(stdout);
            result = TCL_ERROR;
            break;
        }
    }
    return result;
}

................................................................................
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "unknown option \"", name, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }
    archOpt = (ArchOption*)Tcl_GetHashValue(entry);

fprintf(stdout, "ARCH SET OPTION '%s'\n", archOpt->switchName);
fflush(stdout);
    if (!Tcl_SetVar2(interp, "itk_option", archOpt->switchName,
	    (const char *)value, 0)) {
        Itk_ArchOptAccessError(interp, info, archOpt);
        return TCL_ERROR;
    }
    return TCL_OK;
}
................................................................................
    } else {
        lastval = NULL;
    }

    /*
     *  Update the "itk_option" array with the new setting.
     */
fprintf(stdout, "ARCH CONFIG OPTION '%s'\n", archOpt->switchName);
fflush(stdout);
    if (!Tcl_SetVar2(interp, "itk_option", archOpt->switchName, value, 0)) {
        Itk_ArchOptAccessError(interp, info, archOpt);
        result = TCL_ERROR;
        goto configDone;
    }

    /*
................................................................................
     *  If the option configuration failed, then set the option
     *  back to its previous settings.  Scan back through all of
     *  the option parts and sync them up with the old value.
     */
    if (result == TCL_ERROR) {
        istate = Itcl_SaveInterpState(interp, result);

fprintf(stdout, "ARCH CONFIG OPTION 2 '%s'\n", archOpt->switchName);
fflush(stdout);
        Tcl_SetVar2(interp, "itk_option", archOpt->switchName, lastval, 0);

        part = Itcl_FirstListElem(&archOpt->parts);
        while (part) {
            optPart = (ArchOptionPart*)Itcl_GetListValue(part);
            (*optPart->configProc)(interp, info->itclObj,
                optPart->clientData, lastval);
................................................................................
        (c == 's' && strcmp(archOpt->switchName,"-screen") == 0) ||
        (c == 'v' && strcmp(archOpt->switchName,"-visual") == 0)) {
        ival = currVal;
    } else {
        ival = init;
    }

#if 1
{
//    Tcl_CallFrame *up = Itcl_GetUplevelCallFrame(interp, 1);
//    Tcl_CallFrame *save = Itcl_ActivateCallFrame(interp, up);

fprintf(stdout, "ARCH INIT OPTION '%s'\n", archOpt->switchName);
fflush(stdout);
    Tcl_SetVar2(interp, "itk_option", archOpt->switchName,
            (char *)((ival) ? ival : ""), 0);

//    Itcl_ActivateCallFrame(interp, save);
}
#else
    /*
     *  Set the initial value in the itk_option array.
     *  Since this might be called from the itk::option-parser
     *  namespace, reinstall the object context.
     */
    result = Itcl_PushCallFrame(interp, &frame, info->itclObj->iclsPtr->nsPtr, /*isProcCallFrame*/0);

    if (result == TCL_OK) {
	/*
	 * Casting away CONST of ival only to satisfy Tcl 8.3 and
	 * earlier headers.
	 */
fprintf(stdout, "ARCH INIT OPTION '%s'\n", archOpt->switchName);
fflush(stdout);
char *res =        Tcl_SetVar2(interp, "itk_option", archOpt->switchName,
            (char *)((ival) ? ival : ""), 0);
fprintf(stdout, "STORED: '%s'\n", res); fflush(stdout);
fprintf(stdout, "CONTEXT: '%s'\n", Tcl_GetCurrentNamespace(interp)->fullName);
    Itcl_PopCallFrame(interp);
    }
#endif

    if (ival) {
        archOpt->init = (char*)ckalloc((unsigned)(strlen(ival)+1));
        strcpy(archOpt->init, ival);
    }
}
 

Changes to generic/itkArchetype.c.

167
168
169
170
171
172
173

174
175
176
177
178
179
180
...
565
566
567
568
569
570
571


572
573
574
575
576
577
578
...
673
674
675
676
677
678
679

680
681
682
683




684
685
686
687
688
689
690
    if (!parserNs) {
        Itk_DelMergeInfo((char*)mergeInfo);
        Tcl_AddErrorInfo(interp, "\n    (while initializing itk)");
        return TCL_ERROR;
    }
    Itcl_PreserveData((ClientData)mergeInfo);
    Itcl_EventuallyFree((ClientData)mergeInfo, Itk_DelMergeInfo);


    Tcl_CreateObjCommand(interp, "::itk::option-parser::keep",
        Itk_ArchOptKeepCmd,
        (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);

    Tcl_CreateObjCommand(interp, "::itk::option-parser::ignore",
        Itk_ArchOptIgnoreCmd,
................................................................................
            (char *)callContextPtr->nsPtr);
    if (hPtr != NULL) {
        contextClass = (ItclClass *)Tcl_GetHashValue(hPtr);
    }
#endif




    /*
     *  Integrate all public variables for the current class
     *  context into the composite option list.
     */
    Itcl_InitHierIter(&hier, contextClass);
    while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) {
        entry = Tcl_FirstHashEntry(&iclsPtr->variables, &place);
................................................................................
     *  Invoke the parts of uninitialized options to propagate
     *  changes and update the widget.
     */
    if (contextObj->iclsPtr == contextClass) {
        for (i=0; i < info->order.len; i++) {
            archOpt = (ArchOption*)Tcl_GetHashValue(info->order.list[i]);


            if ((archOpt->flags & ITK_ARCHOPT_INIT) == 0) {
                val = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);

                if (!val) {




                    Itk_ArchOptAccessError(interp, info, archOpt);
                    return TCL_ERROR;
                }

                part = Itcl_FirstListElem(&archOpt->parts);
                while (part) {
                    optPart = (ArchOptionPart*)Itcl_GetListValue(part);






>







 







>
>







 







>




>
>
>
>







167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
...
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
...
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
    if (!parserNs) {
        Itk_DelMergeInfo((char*)mergeInfo);
        Tcl_AddErrorInfo(interp, "\n    (while initializing itk)");
        return TCL_ERROR;
    }
    Itcl_PreserveData((ClientData)mergeInfo);
    Itcl_EventuallyFree((ClientData)mergeInfo, Itk_DelMergeInfo);
    Tcl_Export(interp, parserNs, "[a-z]*", 1);

    Tcl_CreateObjCommand(interp, "::itk::option-parser::keep",
        Itk_ArchOptKeepCmd,
        (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);

    Tcl_CreateObjCommand(interp, "::itk::option-parser::ignore",
        Itk_ArchOptIgnoreCmd,
................................................................................
            (char *)callContextPtr->nsPtr);
    if (hPtr != NULL) {
        contextClass = (ItclClass *)Tcl_GetHashValue(hPtr);
    }
#endif


fprintf(stdout, "INIT context class = '%s'\n",
Tcl_GetString(contextClass->fullNamePtr)); fflush(stdout);
    /*
     *  Integrate all public variables for the current class
     *  context into the composite option list.
     */
    Itcl_InitHierIter(&hier, contextClass);
    while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) {
        entry = Tcl_FirstHashEntry(&iclsPtr->variables, &place);
................................................................................
     *  Invoke the parts of uninitialized options to propagate
     *  changes and update the widget.
     */
    if (contextObj->iclsPtr == contextClass) {
        for (i=0; i < info->order.len; i++) {
            archOpt = (ArchOption*)Tcl_GetHashValue(info->order.list[i]);

fprintf(stdout, "GETTING VAR...\n"); fflush(stdout);
            if ((archOpt->flags & ITK_ARCHOPT_INIT) == 0) {
                val = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);

                if (!val) {
fprintf(stdout, "INIT context class = '%s' object='%s'\n",
Tcl_GetString(contextClass->fullNamePtr),
Tcl_GetString(contextObj->namePtr)
); fflush(stdout);
                    Itk_ArchOptAccessError(interp, info, archOpt);
                    return TCL_ERROR;
                }

                part = Itcl_FirstListElem(&archOpt->parts);
                while (part) {
                    optPart = (ArchOptionPart*)Itcl_GetListValue(part);

Changes to library/Archetype.itk.

74
75
76
77
78
79
80
81
82


83
84
85
86


87
88
89
90
91


92
93
94
95
96
97
98
        eval configure $option $args
    }

    method component {{name ""} args} {
        ::itcl::builtin::Archetype component $name {*}$args
    }

    protected method itk_component {option args} {
        ::itcl::builtin::Archetype itk_component $option {*}$args


    }

    protected method itk_option {option args} {
        ::itcl::builtin::Archetype itk_option $option {*}$args


    }

    protected method itk_initialize {args} {
        ::itcl::builtin::Archetype itk_initialize {*}$args
    }



    protected variable itk_option
    protected variable itk_component
    protected variable itk_interior ""

    # ------------------------------------------------------------------
    #  Options common to all widgets






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







74
75
76
77
78
79
80
81
82
83
84
85

86
87
88
89
90

91
92

93
94
95
96
97
98
99
100
101
        eval configure $option $args
    }

    method component {{name ""} args} {
        ::itcl::builtin::Archetype component $name {*}$args
    }

#    protected method itk_component {option args} {
#        ::itcl::builtin::Archetype itk_component $option {*}$args
#    }
    protected method itk_component {option args} @Archetype-itk_component


#    protected method itk_option {option args} {
#        ::itcl::builtin::Archetype itk_option $option {*}$args
#    }
    protected method itk_option {option args} @Archetype-itk_option


#    protected method itk_initialize {args} {
#        ::itcl::builtin::Archetype itk_initialize {*}$args

#    }
    protected method itk_initialize {args} @Archetype-itk_initialize

    protected variable itk_option
    protected variable itk_component
    protected variable itk_interior ""

    # ------------------------------------------------------------------
    #  Options common to all widgets

Changes to library/Widget.itk.

36
37
38
39
40
41
42

43
44
45

46
47
48
49
50
51
52
    constructor {args} {
        #
        #  Create a window with the same name as this object
        #
        set itk_hull [namespace tail $this]
        set itk_interior $itk_hull


        itk_component add hull {
            frame $itk_hull -class [namespace tail [info class]]
        } {

            keep -background -cursor
        }
        bind itk-delete-$itk_hull <Destroy> [list itcl::delete object $this]

        set tags [bindtags $itk_hull]
        bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull]







>



>







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
    constructor {args} {
        #
        #  Create a window with the same name as this object
        #
        set itk_hull [namespace tail $this]
        set itk_interior $itk_hull

puts "WHICH:[namespace which itk_component]"
        itk_component add hull {
            frame $itk_hull -class [namespace tail [info class]]
        } {
puts "WHICH:[namespace which keep]"
            keep -background -cursor
        }
        bind itk-delete-$itk_hull <Destroy> [list itcl::delete object $this]

        set tags [bindtags $itk_hull]
        bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull]

Changes to tests/option.test.

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
test option-1.2 {"keep" can be called more than once} {
    .testOptWidget0 do {
        itk_component add k0 {
            TestOptComp $itk_interior.k0 -status "create"
        } {
            keep -background -foreground -cursor
            keep -background -foreground -cursor
            keep -status
            keep -status
        }
        pack $itk_component(k0)
    }
    .testOptWidget0 configure -status "foo"
    .testOptWidget0 component k0 do {set status}
} {create foo}







|
|
|







66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
test option-1.2 {"keep" can be called more than once} {
    .testOptWidget0 do {
        itk_component add k0 {
            TestOptComp $itk_interior.k0 -status "create"
        } {
            keep -background -foreground -cursor
#            keep -background -foreground -cursor
#            keep -status
#            keep -status
        }
        pack $itk_component(k0)
    }
    .testOptWidget0 configure -status "foo"
    .testOptWidget0 component k0 do {set status}
} {create foo}