Itk - the [incr Tk] extension

Check-in [b46f3c3fe0]
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:Several revisions to get evaluation contexts more reliably correct.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dgp-method-type
Files: files | file ages | folders
SHA1:b46f3c3fe00d0d0e617d4ddfd7dd95a377fe8810
User & Date: dgp 2017-07-28 16:57:26
Context
2017-07-28
17:04
Repurpose the trunk for ongoing development of Itk 4.1.*. check-in: fc469d3c3b user: dgp tags: trunk, itk-4-1-0
16:57
Several revisions to get evaluation contexts more reliably correct. Closed-Leaf check-in: b46f3c3fe0 user: dgp tags: dgp-method-type
15:57
Take care that the right commands are resolved in the right namespaces. Closed-Leaf check-in: fd54e0d1dc user: dgp tags: experiment
2017-07-10
18:32
[6acb6a8363] When Itk_AddOptionPart() fails, be sure no remnant of the failed attempt remains to lead to nasty double free. check-in: 46e858f9ac user: dgp tags: dgp-method-type
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to generic/itkArchBase.c.

   387    387            *  Add a binding onto the new component, so that when its
   388    388            *  window is destroyed, it will automatically remove itself
   389    389            *  from its parent's component list.  Avoid doing these things
   390    390            *  for the "hull" component, since it is a special case and
   391    391            *  these things are not really necessary.
   392    392            */
   393    393           Tcl_DStringSetLength(&buffer, 0);
   394         -        Tcl_DStringAppend(&buffer, "bindtags ", -1);
          394  +        Tcl_DStringAppend(&buffer, "::bindtags ", -1);
   395    395           Tcl_DStringAppend(&buffer, path, -1);
   396    396           if (Tcl_Eval(interp, Tcl_DStringValue(&buffer)) != TCL_OK) {
   397    397               goto compFail;
   398    398           }
   399    399   
          400  +	/*
          401  +	 * NOTE: We need the [::itcl::code] because the itk_component
          402  +	 * method is protected.
          403  +	 */
          404  +
   400    405           Tcl_DStringSetLength(&buffer, 0);
   401         -        Tcl_DStringAppend(&buffer, "bind itk-destroy-", -1);
          406  +        Tcl_DStringAppend(&buffer, "::bind itk-destroy-", -1);
   402    407           Tcl_DStringAppend(&buffer, path, -1);
   403         -        Tcl_DStringAppend(&buffer, " <Destroy> [itcl::code ", -1);
          408  +        Tcl_DStringAppend(&buffer, " <Destroy> [::itcl::code ", -1);
   404    409   
   405    410           Tcl_DStringAppend(&buffer,
   406    411               Tcl_GetStringFromObj(objNamePtr,(int*)NULL), -1);
   407    412   
   408    413           Tcl_DStringAppend(&buffer, " itk_component delete ", -1);
   409    414           Tcl_DStringAppend(&buffer, name, -1);
   410    415           Tcl_DStringAppend(&buffer, "]\n", -1);
   411         -        Tcl_DStringAppend(&buffer, "bindtags ", -1);
          416  +        Tcl_DStringAppend(&buffer, "::bindtags ", -1);
   412    417           Tcl_DStringAppend(&buffer, path, -1);
   413    418           Tcl_DStringAppend(&buffer, " {itk-destroy-", -1);
   414    419           Tcl_DStringAppend(&buffer, path, -1);
   415    420           Tcl_DStringAppend(&buffer, " ", -1);
   416    421           Tcl_DStringAppend(&buffer, Tcl_GetStringResult(interp), -1);
   417    422           Tcl_DStringAppend(&buffer, "}", -1);
          423  +
   418    424           if (Tcl_Eval(interp, Tcl_DStringValue(&buffer)) != TCL_OK) {
   419    425               goto compFail;
   420    426           }
   421    427       }
   422    428   
   423    429       /*
   424    430        *  Query the list of configuration options for this widget,
................................................................................
   474    480       if (objc != 4) {
   475    481           objPtr = Tcl_NewStringObj("usual", -1);
   476    482           Tcl_IncrRefCount(objPtr);
   477    483       } else {
   478    484           objPtr = objv[3];
   479    485       }
   480    486   
   481         -    Tcl_Import(interp, NULL, "::itk::option-parser::*", 1);
   482         -
   483         -    if (result == TCL_OK) {
   484         -        result = Tcl_EvalObj(interp, objPtr);
   485         -	Tcl_ForgetImport(interp, NULL, "::itk::option-parser::*");
   486         -    }
          487  +    Tcl_Eval(interp, "::namespace path [::lreplace [::namespace path] end+1 end ::itk::option-parser]");
          488  +    result = Tcl_EvalObj(interp, objPtr);
          489  +    Tcl_Eval(interp, "::namespace path [::lrange [::namespace path] 0 end-1]");
   487    490   
   488    491       if (objc != 4) {
   489    492           Tcl_DecrRefCount(objPtr);
   490    493       }
   491    494       if (result != TCL_OK) {
   492    495           goto compFail;
   493    496       }
................................................................................
   643    646   
   644    647          /*
   645    648           *  Clean up the binding tag that causes the widget to
   646    649           *  call this method automatically when destroyed.
   647    650           *  Ignore errors if anything goes wrong.
   648    651           */
   649    652           Tcl_DStringInit(&buffer);
   650         -        Tcl_DStringAppend(&buffer, "itk::remove_destroy_hook ", -1);
          653  +        Tcl_DStringAppend(&buffer, "::itk::remove_destroy_hook ", -1);
   651    654           Tcl_DStringAppend(&buffer, archComp->pathName, -1);
   652    655           (void) Tcl_Eval(interp, Tcl_DStringValue(&buffer));
   653    656           Tcl_ResetResult(interp);
   654    657           Tcl_DStringFree(&buffer);
   655    658   
   656    659           Tcl_UnsetVar2(interp, "itk_component", token, 0);
   657    660           Tcl_DeleteHashEntry(entry);
................................................................................
  1593   1596        */
  1594   1597   
  1595   1598       if (result == TCL_OK) {
  1596   1599   	/*
  1597   1600   	 * Casting away CONST of newval only to satisfy Tcl 8.3 and
  1598   1601   	 * earlier headers.
  1599   1602   	 */
         1603  +
         1604  +#if 1
         1605  +	val = ItclSetInstanceVar(interp, Tcl_GetString(ivPtr->fullNamePtr),
         1606  +		NULL, newval, contextObj, ivPtr->iclsPtr);
         1607  +#else
  1600   1608           val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), (char *) NULL,
  1601   1609               (char *) newval, TCL_LEAVE_ERR_MSG);
         1610  +#endif
  1602   1611   
  1603   1612           if (!val) {
  1604   1613               result = TCL_ERROR;
  1605   1614           }
  1606   1615       }
  1607   1616   
  1608   1617       if (result != TCL_OK) {
................................................................................
  1616   1625        *  If this variable has some "config" code, invoke it now.
  1617   1626        *
  1618   1627        *  NOTE:  Invoke the "config" code in the class scope
  1619   1628        *    containing the data member.
  1620   1629        */
  1621   1630       mcode = ivPtr->codePtr;
  1622   1631       if (mcode && mcode->bodyPtr) {
  1623         -        Tcl_Namespace *saveNsPtr;
  1624         -        Itcl_SetCallFrameResolver(interp, ivPtr->iclsPtr->resolvePtr);
  1625         -        saveNsPtr = Tcl_GetCurrentNamespace(interp);
  1626         -        Itcl_SetCallFrameNamespace(interp, ivPtr->iclsPtr->nsPtr);
         1632  +	Tcl_CallFrame frame;
         1633  +
         1634  +	Itcl_PushCallFrame(interp, &frame, ivPtr->iclsPtr->nsPtr, 1);
         1635  +	Itcl_SetContext(interp, contextObj);
         1636  +
  1627   1637           result = Tcl_EvalObjEx(interp, mcode->bodyPtr, 0);
  1628         -        Itcl_SetCallFrameNamespace(interp, saveNsPtr);
         1638  +
         1639  +	Itcl_UnsetContext(interp);
         1640  +	Itcl_PopCallFrame(interp);
  1629   1641   
  1630   1642           if (result == TCL_OK) {
  1631   1643               Tcl_ResetResult(interp);
  1632   1644           } else {
  1633   1645               char msg[256];
  1634   1646               sprintf(msg, "\n    (error in configuration of public variable \"%.100s\")", Tcl_GetString(ivPtr->fullNamePtr));
  1635   1647               Tcl_AddErrorInfo(interp, msg);
................................................................................
  1721   1733       CONST char *v; 
  1722   1734       char *lastval;
  1723   1735       Tcl_HashEntry *entry;
  1724   1736       ArchOption *archOpt;
  1725   1737       Itcl_ListElem *part;
  1726   1738       ArchOptionPart *optPart;
  1727   1739       Itcl_InterpState istate;
         1740  +    ItclClass *iclsPtr;
         1741  +    ItclObject *ioPtr;
  1728   1742   
  1729   1743       /*
  1730   1744        *  Query the "itk_option" array to get the current setting.
  1731   1745        */
  1732   1746       entry = Tcl_FindHashEntry(&info->options, name);
  1733   1747       if (!entry) {
  1734   1748           /* Bug 227876
................................................................................
  1739   1753           Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1740   1754               "unknown option \"", name, "\"",
  1741   1755               (char*)NULL);
  1742   1756           return TCL_ERROR;
  1743   1757       }
  1744   1758       archOpt = (ArchOption*)Tcl_GetHashValue(entry);
  1745   1759   
         1760  +#if 0
  1746   1761       v = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);
         1762  +#else
         1763  +    Itcl_GetContext(interp, &iclsPtr, &ioPtr);
         1764  +
         1765  +    v = ItclGetInstanceVar(interp, "itk_option", archOpt->switchName,
         1766  +	    ioPtr, iclsPtr);
         1767  +#endif
         1768  +
  1747   1769       if (v) {
  1748   1770           lastval = (char*)ckalloc((unsigned)(strlen(v)+1));
  1749   1771           strcpy(lastval, v);
  1750   1772       } else {
  1751   1773           lastval = NULL;
  1752   1774       }
  1753   1775   
  1754   1776       /*
  1755   1777        *  Update the "itk_option" array with the new setting.
  1756   1778        */
         1779  +#if 0
  1757   1780       if (!Tcl_SetVar2(interp, "itk_option", archOpt->switchName, value, 0)) {
         1781  +#else
         1782  +    if (!ItclSetInstanceVar(interp, "itk_option", archOpt->switchName, value,
         1783  +	    ioPtr, iclsPtr)) {
         1784  +#endif
  1758   1785           Itk_ArchOptAccessError(interp, info, archOpt);
  1759   1786           result = TCL_ERROR;
  1760   1787           goto configDone;
  1761   1788       }
  1762   1789   
  1763   1790       /*
  1764   1791        *  Scan through all option parts to handle the new setting.
................................................................................
  1782   1809        *  If the option configuration failed, then set the option
  1783   1810        *  back to its previous settings.  Scan back through all of
  1784   1811        *  the option parts and sync them up with the old value.
  1785   1812        */
  1786   1813       if (result == TCL_ERROR) {
  1787   1814           istate = Itcl_SaveInterpState(interp, result);
  1788   1815   
         1816  +#if 0
  1789   1817           Tcl_SetVar2(interp, "itk_option", archOpt->switchName, lastval, 0);
         1818  +#else
         1819  +	ItclSetInstanceVar(interp, "itk_option", archOpt->switchName, lastval,
         1820  +	    ioPtr, iclsPtr);
         1821  +#endif
  1790   1822   
  1791   1823           part = Itcl_FirstListElem(&archOpt->parts);
  1792   1824           while (part) {
  1793   1825               optPart = (ArchOptionPart*)Itcl_GetListValue(part);
  1794   1826               (*optPart->configProc)(interp, info->itclObj,
  1795   1827                   optPart->clientData, lastval);
  1796   1828   

Changes to generic/itkArchetype.c.

   162    162       if (!parserNs) {
   163    163           Itk_DelMergeInfo((char*)mergeInfo);
   164    164           Tcl_AddErrorInfo(interp, "\n    (while initializing itk)");
   165    165           return TCL_ERROR;
   166    166       }
   167    167       Itcl_PreserveData((ClientData)mergeInfo);
   168    168       Itcl_EventuallyFree((ClientData)mergeInfo, Itk_DelMergeInfo);
   169         -    Tcl_Export(interp, parserNs, "[a-z]*", 1);
   170    169   
   171    170       Tcl_CreateObjCommand(interp, "::itk::option-parser::keep",
   172    171           Itk_ArchOptKeepCmd,
   173    172           (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);
   174    173   
   175    174       Tcl_CreateObjCommand(interp, "::itk::option-parser::ignore",
   176    175           Itk_ArchOptIgnoreCmd,
................................................................................
  1064   1063   	}
  1065   1064       }
  1066   1065       ItclShowArgs(1, "Itk_ArchConfigureCmd2", objc, objv);
  1067   1066       if (objc == 1) {
  1068   1067           Tcl_DStringInit(&buffer);
  1069   1068   
  1070   1069           for (i=0; i < info->order.len; i++) {
  1071         -	    Tcl_Namespace *save = Tcl_GetCurrentNamespace(interp);
  1072   1070               archOpt = (ArchOption*)Tcl_GetHashValue(info->order.list[i]);
  1073   1071   
  1074         -	    Itcl_SetCallFrameNamespace(interp, contextObj->iclsPtr->nsPtr);
  1075         -            val = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);
  1076         -	    Itcl_SetCallFrameNamespace(interp, save);
         1072  +	    val = ItclGetInstanceVar(interp, "itk_option", archOpt->switchName,
         1073  +		    contextObj, contextClass);
  1077   1074               if (!val) {
  1078   1075                   Itk_ArchOptAccessError(interp, info, archOpt);
  1079   1076                   Tcl_DStringFree(&buffer);
  1080   1077                   return TCL_ERROR;
  1081   1078               }
  1082   1079   
  1083   1080               Tcl_DStringStartSublist(&buffer);
................................................................................
  1098   1095   
  1099   1096           /*
  1100   1097            *  If there is just one argument, then query the information
  1101   1098            *  for that one argument and return:
  1102   1099            *    {name resName resClass init value}
  1103   1100            */
  1104   1101           if (objc == 2) {
  1105         -	    Tcl_Namespace *save = Tcl_GetCurrentNamespace(interp);
  1106   1102               token = Tcl_GetString(objv[1]);
  1107   1103               entry = Tcl_FindHashEntry(&info->options, token);
  1108   1104               if (!entry) {
  1109   1105                   Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1110   1106                       "unknown option \"", token, "\"",
  1111   1107                       (char*)NULL);
  1112   1108                   return TCL_ERROR;
  1113   1109               }
  1114   1110   
  1115   1111               archOpt = (ArchOption*)Tcl_GetHashValue(entry);
  1116         -	    Itcl_SetCallFrameNamespace(interp, contextObj->iclsPtr->nsPtr);
  1117         -            val = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);
  1118         -	    Itcl_SetCallFrameNamespace(interp, save);
         1112  +
         1113  +	    val = ItclGetInstanceVar(interp, "itk_option", archOpt->switchName,
         1114  +		    contextObj, contextClass);
  1119   1115               if (!val) {
  1120   1116                   Itk_ArchOptAccessError(interp, info, archOpt);
  1121   1117                   return TCL_ERROR;
  1122   1118               }
  1123   1119   
  1124   1120               Tcl_AppendElement(interp, archOpt->switchName);
  1125   1121               Tcl_AppendElement(interp,
................................................................................
  1136   1132       /*
  1137   1133        *  Otherwise, it must be a series of "-option value" assignments.
  1138   1134        *  Look up each option and assign the new value.
  1139   1135        */
  1140   1136       for (objc--,objv++; objc > 0; objc-=2, objv+=2) {
  1141   1137   	char *value;
  1142   1138   	int code;
  1143         -	Tcl_Namespace *save = Tcl_GetCurrentNamespace(interp);
         1139  +//	Tcl_Namespace *save = Tcl_GetCurrentNamespace(interp);
  1144   1140           token = Tcl_GetString(objv[0]);
  1145   1141           if (objc < 2) {
  1146   1142               Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1147   1143                   "value for \"", token, "\" missing",
  1148   1144                   (char*)NULL);
  1149   1145               return TCL_ERROR;
  1150   1146           }
  1151   1147           value = Tcl_GetString(objv[1]);
  1152   1148   
  1153         -	Itcl_SetCallFrameNamespace(interp, contextObj->iclsPtr->nsPtr);
         1149  +//	Itcl_SetCallFrameNamespace(interp, contextObj->iclsPtr->nsPtr);
  1154   1150           code = Itk_ArchConfigOption(interp, info, token, value);
  1155         -	Itcl_SetCallFrameNamespace(interp, save);
         1151  +//	Itcl_SetCallFrameNamespace(interp, save);
  1156   1152           if (code != TCL_OK) {
  1157   1153               return TCL_ERROR;
  1158   1154           }
  1159   1155       }
  1160   1156   
  1161   1157       Tcl_ResetResult(interp);
  1162   1158       return TCL_OK;

Changes to generic/itkOption.c.

   213    213       ItclObject *contextObj,    /* object being configured */
   214    214       ClientData cdata,          /* class option */
   215    215       CONST char *newval)        /* new value for this option */
   216    216   {
   217    217       ItkClassOption *opt = (ItkClassOption*)cdata;
   218    218       int result = TCL_OK;
   219    219       ItclMemberCode *mcode;
          220  +    Tcl_CallFrame frame;
   220    221   
   221    222       /*
   222    223        *  If the option has any config code, execute it now.
   223    224        *  Make sure that the namespace context is set up correctly.
   224    225        */
   225    226       mcode = opt->codePtr;
   226    227       if (mcode && mcode->bodyPtr) {
   227         -        Tcl_Namespace *saveNsPtr;
   228         -//fprintf(stderr, "EXE!%s!\n", Tcl_GetString(mcode->bodyPtr));
   229         -        Itcl_SetCallFrameResolver(interp, opt->iclsPtr->resolvePtr);
   230         -        saveNsPtr = Tcl_GetCurrentNamespace(interp);
   231         -//fprintf(stderr, "MCNS!%s!\n", saveNsPtr->fullName);
   232         -        Itcl_SetCallFrameNamespace(interp, opt->iclsPtr->nsPtr);
          228  +
          229  +	Itcl_PushCallFrame(interp, &frame, opt->iclsPtr->nsPtr, 1);
          230  +	Itcl_SetContext(interp, contextObj);
          231  +
   233    232           result = Tcl_EvalObjEx(interp, mcode->bodyPtr, 0);
   234         -        Itcl_SetCallFrameNamespace(interp, saveNsPtr);
          233  +
          234  +	Itcl_UnsetContext(interp);
          235  +	Itcl_PopCallFrame(interp);
   235    236   
   236    237   	/* 
   237    238   	 * Here we engage in some ugly hackery workaround until
   238    239   	 * someone has time to come back and implement this
   239    240   	 * properly.
   240    241   	 *
   241    242   	 * In Itcl/Itk 3, the same machinery was used to implement