Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Comment: | merge trunk |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | novem |
Files: | files | file ages | folders |
SHA1: |
127b30eda569a9f653342308a67f3384 |
User & Date: | jan.nijtmans 2013-02-03 16:05:31 |
2013-02-04
| ||
14:15 | merge trunk check-in: 0439b85bce user: jan.nijtmans tags: novem | |
2013-02-03
| ||
17:17 | merge novem check-in: f0ab71bc6c user: jan.nijtmans tags: novem-more-memory-API | |
16:05 | merge trunk check-in: 127b30eda5 user: jan.nijtmans tags: novem | |
11:34 | More symmetric Tcl_(Incr|Decr)RefCount call, preventing bugs like #3601260 and #3602706 check-in: fa161ec8b8 user: jan.nijtmans tags: trunk | |
2013-01-29
| ||
08:14 | merge trunk check-in: 548bf19900 user: jan.nijtmans tags: novem | |
Changes to ChangeLog.
1 2 3 4 5 6 7 | 2013-01-28 Donal K. Fellows <[email protected]> * generic/tclCompCmds.c (TclCompileArraySetCmd) (TclCompileArrayUnsetCmd, TclCompileDictAppendCmd) (TclCompileDictCreateCmd, CompileDictEachCmd, TclCompileDictIncrCmd) (TclCompileDictLappendCmd, TclCompileDictMergeCmd) (TclCompileDictUnsetCmd, TclCompileDictUpdateCmd) | > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | 2013-01-30 Andreas Kupries <[email protected]> * library/platform/platform.tcl (::platform::LibcVersion): See * library/platform/pkgIndex.tcl: [Bug 3599098]: Fixed the RE * unix/Makefile.in: extracting the version to avoid issues with * win/Makefile.in: recent changes to the glibc banner. Now targeting a less variable part of the string. Bumped package to version 1.0.11. 2013-01-28 Donal K. Fellows <[email protected]> * generic/tclCompCmds.c (TclCompileArraySetCmd) (TclCompileArrayUnsetCmd, TclCompileDictAppendCmd) (TclCompileDictCreateCmd, CompileDictEachCmd, TclCompileDictIncrCmd) (TclCompileDictLappendCmd, TclCompileDictMergeCmd) (TclCompileDictUnsetCmd, TclCompileDictUpdateCmd) |
︙ | ︙ |
Changes to generic/tclAssembly.c.
︙ | ︙ | |||
854 855 856 857 858 859 860 | /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ if (objPtr->typePtr == &assembleCodeType) { namespacePtr = iPtr->varFramePtr->nsPtr; | | | 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 | /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ if (objPtr->typePtr == &assembleCodeType) { namespacePtr = iPtr->varFramePtr->nsPtr; codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == namespacePtr) && (codePtr->nsEpoch == namespacePtr->resolverEpoch) && (codePtr->localCachePtr == iPtr->varFramePtr->localCachePtr)) { return codePtr; |
︙ | ︙ | |||
939 940 941 942 943 944 945 | objPtr->typePtr = &assembleCodeType; TclFreeCompileEnv(&compEnv); /* * Record the local variable context to which the bytecode pertains */ | | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 | objPtr->typePtr = &assembleCodeType; TclFreeCompileEnv(&compEnv); /* * Record the local variable context to which the bytecode pertains */ codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } /* * Report on what the assembler did. |
︙ | ︙ | |||
4332 4333 4334 4335 4336 4337 4338 | *----------------------------------------------------------------------------- */ static void FreeAssembleCodeInternalRep( Tcl_Obj *objPtr) { | | < | 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 | *----------------------------------------------------------------------------- */ static void FreeAssembleCodeInternalRep( Tcl_Obj *objPtr) { ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } objPtr->typePtr = NULL; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclBinary.c.
︙ | ︙ | |||
200 201 202 203 204 205 206 | * field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_SIZE(len) \ ((unsigned) (TclOffset(ByteArray, bytes) + (len))) #define GET_BYTEARRAY(objPtr) \ | | | > | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | * field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_SIZE(len) \ ((unsigned) (TclOffset(ByteArray, bytes) + (len))) #define GET_BYTEARRAY(objPtr) \ ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_BYTEARRAY(objPtr, baPtr) \ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) /* *---------------------------------------------------------------------- * * Tcl_NewByteArrayObj -- * * This procedure is creates a new ByteArray object and initializes it |
︙ | ︙ |
Changes to generic/tclCompExpr.c.
︙ | ︙ | |||
2203 2204 2205 2206 2207 2208 2209 | CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); TclEmitOpcode(INST_DONE, envPtr); Tcl_IncrRefCount(byteCodeObj); TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); | | | 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 | CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); TclEmitOpcode(INST_DONE, envPtr); Tcl_IncrRefCount(byteCodeObj); TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); Tcl_DecrRefCount(byteCodeObj); return code; } /* |
︙ | ︙ |
Changes to generic/tclCompile.c.
︙ | ︙ | |||
840 841 842 843 844 845 846 | *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { | | < | < | | 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 | *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->typePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } } /* *---------------------------------------------------------------------- * * TclCleanupByteCode -- * * This procedure does all the real work of freeing up a bytecode * object's ByteCode structure. It's called only when the structure's * reference count becomes zero. * * Results: * None. * * Side effects: * Frees objPtr's bytecode internal representation and sets its type NULL * Also releases its literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ void TclCleanupByteCode( register ByteCode *codePtr) /* Points to the ByteCode to free. */ |
︙ | ︙ | |||
1140 1141 1142 1143 1144 1145 1146 | TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); TclEmitOpcode(INST_DONE, &compEnv); TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &substCodeType; TclFreeCompileEnv(&compEnv); | | | 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 | TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); TclEmitOpcode(INST_DONE, &compEnv); TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &substCodeType; TclFreeCompileEnv(&compEnv); codePtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->internalRep.ptrAndLongRep.ptr = codePtr; objPtr->internalRep.ptrAndLongRep.value = flags; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } /* TODO: Debug printing? */ |
︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 | static void FreeSubstCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr; objPtr->typePtr = NULL; | < | 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 | static void FreeSubstCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr; objPtr->typePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } } /* |
︙ | ︙ | |||
2635 2636 2637 2638 2639 2640 2641 | /* * Free the old internal rep then convert the object to a bytecode object * by making its internal rep point to the just compiled ByteCode. */ TclFreeIntRep(objPtr); | | | 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 | /* * Free the old internal rep then convert the object to a bytecode object * by making its internal rep point to the just compiled ByteCode. */ TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = codePtr; objPtr->typePtr = &tclByteCodeType; /* * TIP #280. Associate the extended per-word line information with the * byte code object (internal rep), for use with the bc compiler. */ |
︙ | ︙ | |||
4054 4055 4056 4057 4058 4059 4060 | *---------------------------------------------------------------------- */ Tcl_Obj * TclDisassembleByteCodeObj( Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { | | | 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 | *---------------------------------------------------------------------- */ Tcl_Obj * TclDisassembleByteCodeObj( Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_Obj *bufferObj; char ptrBuf1[20], ptrBuf2[20]; |
︙ | ︙ |
Changes to generic/tclDictObj.c.
︙ | ︙ | |||
357 358 359 360 361 362 363 | */ static void DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { | | | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 | */ static void DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1; Dict *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; /* * Copy values across from the old hash table. */ |
︙ | ︙ | |||
392 393 394 395 396 397 398 | newDict->chain = NULL; newDict->refcount = 1; /* * Store in the object. */ | | | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 | newDict->chain = NULL; newDict->refcount = 1; /* * Store in the object. */ copyPtr->internalRep.twoPtrValue.ptr1 = newDict; copyPtr->typePtr = &tclDictType; } /* *---------------------------------------------------------------------- * * FreeDictInternalRep -- |
︙ | ︙ | |||
418 419 420 421 422 423 424 | *---------------------------------------------------------------------- */ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { | | < < | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 | *---------------------------------------------------------------------- */ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; dict->refcount--; if (dict->refcount <= 0) { DeleteDict(dict); } dictPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * * DeleteDict -- |
︙ | ︙ | |||
485 486 487 488 489 490 491 | static void UpdateStringOfDict( Tcl_Obj *dictPtr) { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 | static void UpdateStringOfDict( Tcl_Obj *dictPtr) { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; const char *elem; char *dst; /* |
︙ | ︙ | |||
708 709 710 711 712 713 714 | * Tcl_GetStringFromObj, to use that old internalRep. */ TclFreeIntRep(objPtr); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; | | | 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 | * Tcl_GetStringFromObj, to use that old internalRep. */ TclFreeIntRep(objPtr); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; objPtr->internalRep.twoPtrValue.ptr1 = dict; objPtr->typePtr = &tclDictType; return TCL_OK; missingValue: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value to go with key", -1)); |
︙ | ︙ | |||
777 778 779 780 781 782 783 | int i; if (dictPtr->typePtr != &tclDictType) { if (SetDictFromAny(interp, dictPtr) != TCL_OK) { return NULL; } } | | | 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 | int i; if (dictPtr->typePtr != &tclDictType) { if (SetDictFromAny(interp, dictPtr) != TCL_OK) { return NULL; } } dict = dictPtr->internalRep.twoPtrValue.ptr1; if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } for (i=0 ; i<keyc ; i++) { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, keyv[i]); Tcl_Obj *tmpObj; |
︙ | ︙ | |||
820 821 822 823 824 825 826 | if (tmpObj->typePtr != &tclDictType) { if (SetDictFromAny(interp, tmpObj) != TCL_OK) { return NULL; } } } | | | | 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 | if (tmpObj->typePtr != &tclDictType) { if (SetDictFromAny(interp, tmpObj) != TCL_OK) { return NULL; } } } newDict = tmpObj->internalRep.twoPtrValue.ptr1; if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); tmpObj = Tcl_DuplicateObj(tmpObj); Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; newDict = tmpObj->internalRep.twoPtrValue.ptr1; } newDict->chain = dictPtr; } dict = newDict; dictPtr = tmpObj; } |
︙ | ︙ | |||
863 864 865 866 867 868 869 | *---------------------------------------------------------------------- */ static void InvalidateDictChain( Tcl_Obj *dictObj) { | | | | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 | *---------------------------------------------------------------------- */ static void InvalidateDictChain( Tcl_Obj *dictObj) { Dict *dict = dictObj->internalRep.twoPtrValue.ptr1; do { Tcl_InvalidateStringRep(dictObj); dict->epoch++; dictObj = dict->chain; if (dictObj == NULL) { break; } dict->chain = NULL; dict = dictObj->internalRep.twoPtrValue.ptr1; } while (dict != NULL); } /* *---------------------------------------------------------------------- * * Tcl_DictObjPut -- |
︙ | ︙ | |||
922 923 924 925 926 927 928 | return result; } } if (dictPtr->bytes != NULL) { Tcl_InvalidateStringRep(dictPtr); } | | | 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 | return result; } } if (dictPtr->bytes != NULL) { Tcl_InvalidateStringRep(dictPtr); } dict = dictPtr->internalRep.twoPtrValue.ptr1; hPtr = CreateChainEntry(dict, keyPtr, &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); TclDecrRefCount(oldValuePtr); } |
︙ | ︙ | |||
973 974 975 976 977 978 979 | int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { *valuePtrPtr = NULL; return result; } } | | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 | int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { *valuePtrPtr = NULL; return result; } } dict = dictPtr->internalRep.twoPtrValue.ptr1; hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; } else { *valuePtrPtr = Tcl_GetHashValue(hPtr); } return TCL_OK; |
︙ | ︙ | |||
1024 1025 1026 1027 1028 1029 1030 | return result; } } if (dictPtr->bytes != NULL) { Tcl_InvalidateStringRep(dictPtr); } | | | 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 | return result; } } if (dictPtr->bytes != NULL) { Tcl_InvalidateStringRep(dictPtr); } dict = dictPtr->internalRep.twoPtrValue.ptr1; if (DeleteChainEntry(dict, keyPtr)) { dict->epoch++; } return TCL_OK; } /* |
︙ | ︙ | |||
1064 1065 1066 1067 1068 1069 1070 | if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { return result; } } | | | 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 | if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { return result; } } dict = dictPtr->internalRep.twoPtrValue.ptr1; *sizePtr = dict->table.numEntries; return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1119 1120 1121 1122 1123 1124 1125 | int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { return result; } } | | | 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 | int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { return result; } } dict = dictPtr->internalRep.twoPtrValue.ptr1; cPtr = dict->entryChainHead; if (cPtr == NULL) { searchPtr->epoch = -1; *donePtr = 1; } else { *donePtr = 0; searchPtr->dictionaryPtr = (Tcl_Dict) dict; |
︙ | ︙ | |||
1294 1295 1296 1297 1298 1299 1300 | } dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE); if (dictPtr == NULL) { return TCL_ERROR; } | | | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 | } dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE); if (dictPtr == NULL) { return TCL_ERROR; } dict = dictPtr->internalRep.twoPtrValue.ptr1; hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); TclDecrRefCount(oldValuePtr); } Tcl_SetHashValue(hPtr, valuePtr); |
︙ | ︙ | |||
1350 1351 1352 1353 1354 1355 1356 | } dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE); if (dictPtr == NULL) { return TCL_ERROR; } | | | 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 | } dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE); if (dictPtr == NULL) { return TCL_ERROR; } dict = dictPtr->internalRep.twoPtrValue.ptr1; DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
1396 1397 1398 1399 1400 1401 1402 | TclNewObj(dictPtr); Tcl_InvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; | | | 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 | TclNewObj(dictPtr); Tcl_InvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; dictPtr->internalRep.twoPtrValue.ptr1 = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #endif } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
1445 1446 1447 1448 1449 1450 1451 | TclDbNewObj(dictPtr, file, line); Tcl_InvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; | | | 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 | TclDbNewObj(dictPtr, file, line); Tcl_InvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; dictPtr->internalRep.twoPtrValue.ptr1 = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ return Tcl_NewDictObj(); #endif } |
︙ | ︙ | |||
2057 2058 2059 2060 2061 2062 2063 | dictPtr = objv[1]; if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { return result; } } | | | 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 | dictPtr = objv[1]; if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { return result; } } dict = dictPtr->internalRep.twoPtrValue.ptr1; statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); ckfree(statsStr); return TCL_OK; } |
︙ | ︙ |
Changes to generic/tclEncoding.c.
︙ | ︙ | |||
266 267 268 269 270 271 272 | static int Iso88591ToUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* | | | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 | static int Iso88591ToUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field * of the intrep. This should help the lifetime of encodings be more useful. * See concerns raised in [Bug 1077262]. */ static const Tcl_ObjType encodingType = { "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL }; |
︙ | ︙ | |||
309 310 311 312 313 314 315 | if (objPtr->typePtr != &encodingType) { Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); if (encoding == NULL) { return TCL_ERROR; } TclFreeIntRep(objPtr); | | | | | 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 352 353 354 355 356 357 358 359 360 361 362 363 | if (objPtr->typePtr != &encodingType) { Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); if (encoding == NULL) { return TCL_ERROR; } TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = encoding; objPtr->typePtr = &encodingType; } *encodingPtr = Tcl_GetEncoding(NULL, name); return TCL_OK; } /* *---------------------------------------------------------------------- * * FreeEncodingIntRep -- * * The Tcl_FreeInternalRepProc for the "encoding" Tcl_ObjType. * *---------------------------------------------------------------------- */ static void FreeEncodingIntRep( Tcl_Obj *objPtr) { Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1); objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * * DupEncodingIntRep -- * * The Tcl_DupInternalRepProc for the "encoding" Tcl_ObjType. * *---------------------------------------------------------------------- */ static void DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); } /* *---------------------------------------------------------------------- * * Tcl_GetEncodingSearchPath -- * |
︙ | ︙ |
Changes to generic/tclEnsemble.c.
︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 | * valid cache of discovered information which we can reuse. Do the * check here, and if we're still valid, we can jump straight to the * part where we do the invocation of the subcommand. */ if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){ EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters] | | | 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 | * valid cache of discovered information which we can reuse. Do the * check here, and if we're still valid, we can jump straight to the * part where we do the invocation of the subcommand. */ if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){ EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters] ->internalRep.twoPtrValue.ptr1; if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == ensemblePtr->token) { prefixObj = ensembleCmd->realPrefixObj; Tcl_IncrRefCount(prefixObj); goto runResultingSubcommand; |
︙ | ︙ | |||
2234 2235 2236 2237 2238 2239 2240 | const char *subcommandName, Tcl_Obj *prefixObjPtr) { register EnsembleCmdRep *ensembleCmd; int length; if (objPtr->typePtr == &tclEnsembleCmdType) { | | | | 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 | const char *subcommandName, Tcl_Obj *prefixObjPtr) { register EnsembleCmdRep *ensembleCmd; int length; if (objPtr->typePtr == &tclEnsembleCmdType) { ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); TclNsDecrRefCount(ensembleCmd->nsPtr); ckfree(ensembleCmd->fullSubcmdName); } else { /* * Kill the old internal rep, and replace it with a brand new one of * our own. */ TclFreeIntRep(objPtr); ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; objPtr->typePtr = &tclEnsembleCmdType; } /* * Populate the internal rep. */ |
︙ | ︙ | |||
2641 2642 2643 2644 2645 2646 2647 | *---------------------------------------------------------------------- */ static void FreeEnsembleCmdRep( Tcl_Obj *objPtr) { | | | 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 | *---------------------------------------------------------------------- */ static void FreeEnsembleCmdRep( Tcl_Obj *objPtr) { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); ckfree(ensembleCmd->fullSubcmdName); TclNsDecrRefCount(ensembleCmd->nsPtr); ckfree(ensembleCmd); objPtr->typePtr = NULL; } |
︙ | ︙ | |||
2673 2674 2675 2676 2677 2678 2679 | */ static void DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { | | | | 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 | */ static void DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); int length = strlen(ensembleCmd->fullSubcmdName); copyPtr->typePtr = &tclEnsembleCmdType; copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; ensembleCopy->nsPtr = ensembleCmd->nsPtr; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; ensembleCopy->nsPtr->refCount++; ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj; Tcl_IncrRefCount(ensembleCopy->realPrefixObj); ensembleCopy->fullSubcmdName = ckalloc(length + 1); |
︙ | ︙ | |||
2711 2712 2713 2714 2715 2716 2717 | *---------------------------------------------------------------------- */ static void StringOfEnsembleCmdRep( Tcl_Obj *objPtr) { | | | 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 | *---------------------------------------------------------------------- */ static void StringOfEnsembleCmdRep( Tcl_Obj *objPtr) { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; int length = strlen(ensembleCmd->fullSubcmdName); objPtr->length = length; objPtr->bytes = ckalloc(length + 1); memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); } |
︙ | ︙ |
Changes to generic/tclExecute.c.
︙ | ︙ | |||
1433 1434 1435 1436 1437 1438 1439 | /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ if (objPtr->typePtr == &exprCodeType) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; | | | 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 | /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ if (objPtr->typePtr == &exprCodeType) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { FreeExprCodeInternalRep(objPtr); } |
︙ | ︙ | |||
1473 1474 1475 1476 1477 1478 1479 | * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); | | | 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 | * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile == 2) { TclPrintByteCodeObj(interp, objPtr); |
︙ | ︙ | |||
1545 1546 1547 1548 1549 1550 1551 | *---------------------------------------------------------------------- */ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { | | < | 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 | *---------------------------------------------------------------------- */ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->typePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } } /* |
︙ | ︙ | |||
1606 1607 1608 1609 1610 1611 1612 | * originating procPtr is the same as the current context procPtr * (assuming one exists at all - none for global level). This code is * #def'ed out because [info body] was changed to never return a * bytecode type object, which should obviate us from the extra checks * here. */ | | | 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 | * originating procPtr is the same as the current context procPtr * (assuming one exists at all - none for global level). This code is * #def'ed out because [info body] was changed to never return a * bytecode type object, which should obviate us from the extra checks * here. */ codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { goto recompileObj; } |
︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 | * information. */ iPtr->invokeCmdFramePtr = invoker; iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; | | | 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 | * information. */ iPtr->invokeCmdFramePtr = invoker; iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } return codePtr; } |
︙ | ︙ |
Changes to generic/tclIO.c.
︙ | ︙ | |||
217 218 219 220 221 222 223 | FreeChannelIntRep, /* freeIntRepProc */ DupChannelIntRep, /* dupIntRepProc */ NULL, /* updateStringProc UpdateStringOfChannel */ NULL /* setFromAnyProc SetChannelFromAny */ }; #define GET_CHANNELSTATE(objPtr) \ | | | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | FreeChannelIntRep, /* freeIntRepProc */ DupChannelIntRep, /* dupIntRepProc */ NULL, /* updateStringProc UpdateStringOfChannel */ NULL /* setFromAnyProc SetChannelFromAny */ }; #define GET_CHANNELSTATE(objPtr) \ ((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_CHANNELSTATE(objPtr, storePtr) \ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr)) #define GET_CHANNELINTERP(objPtr) \ ((Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) #define SET_CHANNELINTERP(objPtr, storePtr) \ ((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr)) #define BUSY_STATE(st, fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ |
︙ | ︙ |
Changes to generic/tclIndexObj.c.
︙ | ︙ | |||
49 50 51 52 53 54 55 | DupIndex, /* dupIntRepProc */ UpdateStringOfIndex, /* updateStringProc */ SetIndexFromAny /* setFromAnyProc */ }; /* * The definition of the internal representation of the "index" object; The | | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | DupIndex, /* dupIntRepProc */ UpdateStringOfIndex, /* updateStringProc */ SetIndexFromAny /* setFromAnyProc */ }; /* * The definition of the internal representation of the "index" object; The * internalRep.twoPtrValue.ptr1 field of an object of "index" type will be a * pointer to one of these structures. * * Keep this structure declaration in sync with tclTestObj.c */ typedef struct { void *tablePtr; /* Pointer to the table of strings */ |
︙ | ︙ | |||
213 214 215 216 217 218 219 | offset = (int)sizeof(char *); } /* * See if there is a valid cached result from a previous lookup. */ if (objPtr->typePtr == &indexType) { | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | offset = (int)sizeof(char *); } /* * See if there is a valid cached result from a previous lookup. */ if (objPtr->typePtr == &indexType) { indexRep = objPtr->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; } } /* |
︙ | ︙ | |||
274 275 276 277 278 279 280 | /* * Cache the found representation. Note that we want to avoid allocating a * new internal-rep if at all possible since that is potentially a slow * operation. */ if (objPtr->typePtr == &indexType) { | | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 | /* * Cache the found representation. Note that we want to avoid allocating a * new internal-rep if at all possible since that is potentially a slow * operation. */ if (objPtr->typePtr == &indexType) { indexRep = objPtr->internalRep.twoPtrValue.ptr1; } else { TclFreeIntRep(objPtr); indexRep = ckalloc(sizeof(IndexRep)); objPtr->internalRep.twoPtrValue.ptr1 = indexRep; objPtr->typePtr = &indexType; } indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; indexRep->index = index; *indexPtr = index; |
︙ | ︙ | |||
381 382 383 384 385 386 387 | *---------------------------------------------------------------------- */ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { | | | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 | *---------------------------------------------------------------------- */ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; register char *buf; register unsigned len; register const char *indexStr = EXPAND_OF(indexRep); len = strlen(indexStr); buf = ckalloc(len + 1); memcpy(buf, indexStr, len+1); |
︙ | ︙ | |||
416 417 418 419 420 421 422 | */ static void DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { | | | | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 | */ static void DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep)); memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; dupPtr->typePtr = &indexType; } /* *---------------------------------------------------------------------- * * FreeIndex -- |
︙ | ︙ | |||
445 446 447 448 449 450 451 | *---------------------------------------------------------------------- */ static void FreeIndex( Tcl_Obj *objPtr) { | | | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 | *---------------------------------------------------------------------- */ static void FreeIndex( Tcl_Obj *objPtr) { ckfree(objPtr->internalRep.twoPtrValue.ptr1); objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * * TclInitPrefixCmd -- |
︙ | ︙ | |||
887 888 889 890 891 892 893 | for (i=0 ; i<toPrint ; i++) { /* * Add the element, quoting it if necessary. */ if (origObjv[i]->typePtr == &indexType) { register IndexRep *indexRep = | | | | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 | for (i=0 ; i<toPrint ; i++) { /* * Add the element, quoting it if necessary. */ if (origObjv[i]->typePtr == &indexType) { register IndexRep *indexRep = origObjv[i]->internalRep.twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) { register EnsembleCmdRep *ecrPtr = origObjv[i]->internalRep.twoPtrValue.ptr1; elementStr = ecrPtr->fullSubcmdName; elemLen = strlen(elementStr); } else { elementStr = TclGetStringFromObj(origObjv[i], &elemLen); } flags = 0; |
︙ | ︙ | |||
942 943 944 945 946 947 948 | /* * If the object is an index type use the index table which allows for * the correct error message even if the subcommand was abbreviated. * Otherwise, just use the string rep. */ if (objv[i]->typePtr == &indexType) { | | | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 | /* * If the object is an index type use the index table which allows for * the correct error message even if the subcommand was abbreviated. * Otherwise, just use the string rep. */ if (objv[i]->typePtr == &indexType) { register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); } else if (objv[i]->typePtr == &tclEnsembleCmdType) { register EnsembleCmdRep *ecrPtr = objv[i]->internalRep.twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). */ |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
392 393 394 395 396 397 398 | */ #define TCL_CREATE_NS_IF_UNKNOWN 0x800 #define TCL_FIND_ONLY_NS 0x1000 /* * The data cached in an ensemble subcommand's Tcl_Obj rep (reference in | | | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 | */ #define TCL_CREATE_NS_IF_UNKNOWN 0x800 #define TCL_FIND_ONLY_NS 0x1000 /* * The data cached in an ensemble subcommand's Tcl_Obj rep (reference in * twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs * referring to the same subcommand, even where one is a duplicate of another. */ typedef struct { Namespace *nsPtr; /* The namespace backing the ensemble which * this is a subcommand of. */ int epoch; /* Used to confirm when the data in this |
︙ | ︙ | |||
4048 4049 4050 4051 4052 4053 4054 | AllocCache *cachePtr; \ if (((interp) == NULL) || \ ((cachePtr = ((Interp *)(interp))->allocCache), \ (cachePtr->numObjects == 0))) { \ (objPtr) = TclThreadAllocObj(); \ } else { \ (objPtr) = cachePtr->firstObjPtr; \ | | | | 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 | AllocCache *cachePtr; \ if (((interp) == NULL) || \ ((cachePtr = ((Interp *)(interp))->allocCache), \ (cachePtr->numObjects == 0))) { \ (objPtr) = TclThreadAllocObj(); \ } else { \ (objPtr) = cachePtr->firstObjPtr; \ cachePtr->firstObjPtr = (objPtr)->internalRep.twoPtrValue.ptr1; \ --cachePtr->numObjects; \ } \ } while (0) # define TclFreeObjStorageEx(interp, objPtr) \ do { \ AllocCache *cachePtr; \ if (((interp) == NULL) || \ ((cachePtr = ((Interp *)(interp))->allocCache), \ (cachePtr->numObjects >= ALLOC_NOBJHIGH))) { \ TclThreadFreeObj(objPtr); \ } else { \ (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \ cachePtr->firstObjPtr = objPtr; \ ++cachePtr->numObjects; \ } \ } while (0) #else /* not PURIFY or USE_THREAD_ALLOC */ |
︙ | ︙ | |||
4089 4090 4091 4092 4093 4094 4095 | do { \ Tcl_MutexLock(&tclObjMutex); \ if (tclFreeObjList == NULL) { \ TclAllocateFreeObjects(); \ } \ (objPtr) = tclFreeObjList; \ tclFreeObjList = (Tcl_Obj *) \ | | | | 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 | do { \ Tcl_MutexLock(&tclObjMutex); \ if (tclFreeObjList == NULL) { \ TclAllocateFreeObjects(); \ } \ (objPtr) = tclFreeObjList; \ tclFreeObjList = (Tcl_Obj *) \ tclFreeObjList->internalRep.twoPtrValue.ptr1; \ Tcl_MutexUnlock(&tclObjMutex); \ } while (0) # define TclFreeObjStorageEx(interp, objPtr) \ do { \ Tcl_MutexLock(&tclObjMutex); \ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \ tclFreeObjList = (objPtr); \ Tcl_MutexUnlock(&tclObjMutex); \ } while (0) #endif #else /* TCL_MEM_DEBUG */ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, |
︙ | ︙ |
Changes to generic/tclListObj.c.
︙ | ︙ | |||
1728 1729 1730 1731 1732 1733 1734 | for (i = 0; i < numElems; i++) { Tcl_DecrRefCount(elemPtrs[i]); } ckfree(listRepPtr); } | < < | 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 | for (i = 0; i < numElems; i++) { Tcl_DecrRefCount(elemPtrs[i]); } ckfree(listRepPtr); } listPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * * DupListInternalRep -- |
︙ | ︙ |
Changes to generic/tclOOCall.c.
︙ | ︙ | |||
174 175 176 177 178 179 180 | StashCallChain( Tcl_Obj *objPtr, CallChain *callPtr) { callPtr->refCount++; TclFreeIntRep(objPtr); objPtr->typePtr = &methodNameType; | | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | StashCallChain( Tcl_Obj *objPtr, CallChain *callPtr) { callPtr->refCount++; TclFreeIntRep(objPtr); objPtr->typePtr = &methodNameType; objPtr->internalRep.twoPtrValue.ptr1 = callPtr; } void TclOOStashContext( Tcl_Obj *objPtr, CallContext *contextPtr) { |
︙ | ︙ | |||
201 202 203 204 205 206 207 | */ static void DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { | | | | < | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 | */ static void DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; dstPtr->typePtr = &methodNameType; dstPtr->internalRep.twoPtrValue.ptr1 = callPtr; callPtr->refCount++; } static void FreeMethodNameRep( Tcl_Obj *objPtr) { register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; TclOODeleteChain(callPtr); objPtr->typePtr = NULL; } /* * ---------------------------------------------------------------------- * * TclOOInvokeContext -- |
︙ | ︙ | |||
948 949 950 951 952 953 954 | * there are multiple different layers of cache (in the Tcl_Obj, in * the object, and in the class). */ const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); if (cacheInThisObj->typePtr == &methodNameType) { | | | 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 | * there are multiple different layers of cache (in the Tcl_Obj, in * the object, and in the class). */ const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); if (cacheInThisObj->typePtr == &methodNameType) { callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; } FreeMethodNameRep(cacheInThisObj); } |
︙ | ︙ |
Changes to generic/tclOOMethod.c.
︙ | ︙ | |||
856 857 858 859 860 861 862 | * that we have bytecode, but also that it remains valid. Note that we set * the namespace of the code here directly; this is a hack, but the * alternative is *so* slow... */ if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { ByteCode *codePtr = | | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 | * that we have bytecode, but also that it remains valid. Note that we set * the namespace of the code here directly; this is a hack, but the * alternative is *so* slow... */ if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { ByteCode *codePtr = pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; codePtr->nsPtr = nsPtr; } result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr); if (result != TCL_OK) { goto failureReturn; |
︙ | ︙ |
Changes to generic/tclObj.c.
︙ | ︙ | |||
1251 1252 1253 1254 1255 1256 1257 | * * Results: * None. * * Side effects: * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the * first of a number of free Tcl_Obj's linked together by their | | | 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 | * * Results: * None. * * Side effects: * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the * first of a number of free Tcl_Obj's linked together by their * internalRep.twoPtrValue.ptr1's. * *---------------------------------------------------------------------- */ #define OBJS_TO_ALLOC_EACH_TIME 100 void |
︙ | ︙ | |||
1280 1281 1282 1283 1284 1285 1286 | */ basePtr = ckalloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { | | | 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 | */ basePtr = ckalloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { objPtr->internalRep.twoPtrValue.ptr1 = prevPtr; prevPtr = objPtr; objPtr++; } tclFreeObjList = prevPtr; } #undef OBJS_TO_ALLOC_EACH_TIME |
︙ | ︙ | |||
4386 4387 4388 4389 4390 4391 4392 | * Free the old internalRep before setting the new one. Do this after * getting the string rep to allow the conversion code (in particular, * Tcl_GetStringFromObj) to use that old internalRep. */ if (cmdPtr) { cmdPtr->refCount++; | | | 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 | * Free the old internalRep before setting the new one. Do this after * getting the string rep to allow the conversion code (in particular, * Tcl_GetStringFromObj) to use that old internalRep. */ if (cmdPtr) { cmdPtr->refCount++; resPtr = objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr == &tclCmdNameType) && resPtr && (resPtr->refCount == 1)) { /* * Reuse the old ResolvedCmdName struct instead of freeing it */ Command *oldCmdPtr = resPtr->cmdPtr; |
︙ | ︙ |
Changes to generic/tclPathObj.c.
︙ | ︙ | |||
105 106 107 108 109 110 111 | #define TCLPATH_NEEDNORM 4 /* * Define some macros to give us convenient access to path-object specific * fields. */ | | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | #define TCLPATH_NEEDNORM 4 /* * Define some macros to give us convenient access to path-object specific * fields. */ #define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1) #define SETPATHOBJ(pathPtr,fsPathPtr) \ ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr)) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* *--------------------------------------------------------------------------- * * TclFSNormalizeAbsolutePath -- * |
︙ | ︙ |
Changes to generic/tclProc.c.
︙ | ︙ | |||
417 418 419 420 421 422 423 | * * We don't create and initialize a Proc structure for the procedure; * rather, we use what is in the body object. We increment the ref * count of the Proc struct since the command (soon to be created) * will be holding a reference to it. */ | | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 | * * We don't create and initialize a Proc structure for the procedure; * rather, we use what is in the body object. We increment the ref * count of the Proc struct since the command (soon to be created) * will be holding a reference to it. */ procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; } else { /* * If the procedure's body object is shared because its string value * is identical to, e.g., the body of another procedure, we must |
︙ | ︙ | |||
1193 1194 1195 1196 1197 1198 1199 | Tcl_Obj *bodyPtr; ByteCode *codePtr; bodyPtr = framePtr->procPtr->bodyPtr; if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } | | | 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 | Tcl_Obj *bodyPtr; ByteCode *codePtr; bodyPtr = framePtr->procPtr->bodyPtr; if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { InitLocalCache(framePtr->procPtr) ; } framePtr->localCachePtr = codePtr->localCachePtr; framePtr->localCachePtr->refCount++; |
︙ | ︙ | |||
1364 1365 1366 1367 1368 1369 1370 | } static void InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; | | | 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 | } static void InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; int localCt = procPtr->numCompiledLocals; int numArgs = procPtr->numArgs, i = 0; Tcl_Obj **namePtr; Var *varPtr; LocalCache *localCachePtr; CompiledLocal *localPtr; |
︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 | * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ int skip) /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; | | | 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 | * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ int skip) /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; register Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; /* * Make sure that the local cache of variable names and initial values has * been initialised properly . |
︙ | ︙ | |||
1628 1629 1630 1631 1632 1633 1634 | * the bytecode must be for the right interpreter (no cross-leaks!), * the code must be from the current epoch (so subcommand compilation * is up-to-date), the namespace must match (so variable handling * is right) and the resolverEpoch must match (so that new shadowed * commands and/or resolver changes are considered). */ | | | 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 | * the bytecode must be for the right interpreter (no cross-leaks!), * the code must be from the current epoch (so subcommand compilation * is up-to-date), the namespace must match (so variable handling * is right) and the resolverEpoch must match (so that new shadowed * commands and/or resolver changes are considered). */ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { goto doCompilation; } } else { |
︙ | ︙ | |||
1829 1830 1831 1832 1833 1834 1835 | #endif /* USE_DTRACE */ /* * Invoke the commands in the procedure's body. */ procPtr->refCount++; | | | 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 | #endif /* USE_DTRACE */ /* * Invoke the commands in the procedure's body. */ procPtr->refCount++; codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); return TclNRExecuteByteCode(interp, codePtr); } static int |
︙ | ︙ | |||
1971 1972 1973 1974 1975 1976 1977 | * the context of this procedure.) */ Namespace *nsPtr, /* Namespace containing procedure. */ const char *description, /* string describing this body of code. */ const char *procName) /* Name of this procedure. */ { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; | | | 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 | * the context of this procedure.) */ Namespace *nsPtr, /* Namespace containing procedure. */ const char *description, /* string describing this body of code. */ const char *procName) /* Name of this procedure. */ { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; /* * If necessary, compile the procedure's body. The compiler will allocate * frame slots for the procedure's non-argument local variables. If the * ByteCode already exists, make sure it hasn't been invalidated by * someone redefining a core command (this might make the compiled code * wrong). Also, if the code was compiled in/for a different interpreter, |
︙ | ︙ | |||
2361 2362 2363 2364 2365 2366 2367 | if (!procPtr) { return NULL; } TclNewObj(objPtr); if (objPtr) { objPtr->typePtr = &tclProcBodyType; | | | 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 | if (!procPtr) { return NULL; } TclNewObj(objPtr); if (objPtr) { objPtr->typePtr = &tclProcBodyType; objPtr->internalRep.twoPtrValue.ptr1 = procPtr; procPtr->refCount++; } return objPtr; } |
︙ | ︙ | |||
2391 2392 2393 2394 2395 2396 2397 | */ static void ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { | | | | 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 | */ static void ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; dupPtr->typePtr = &tclProcBodyType; dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; procPtr->refCount++; } /* *---------------------------------------------------------------------- * * ProcBodyFree -- |
︙ | ︙ | |||
2421 2422 2423 2424 2425 2426 2427 | *---------------------------------------------------------------------- */ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { | | < | | 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 | *---------------------------------------------------------------------- */ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; if (procPtr->refCount-- < 2) { TclProcCleanupProc(procPtr); } } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
3058 3059 3060 3061 3062 3063 3064 | CLANG_ASSERT(0); } /* * Do the actual disassembly. */ | | | 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 | CLANG_ASSERT(0); } /* * Do the actual disassembly. */ if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "BYTECODE", NULL); return TCL_ERROR; } |
︙ | ︙ |
Changes to generic/tclRegexp.c.
︙ | ︙ | |||
574 575 576 577 578 579 580 | const char *pattern; /* * This is OK because we only actually interpret this value properly as a * TclRegexp* when the type is tclRegexpType. */ | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 | const char *pattern; /* * This is OK because we only actually interpret this value properly as a * TclRegexp* when the type is tclRegexpType. */ regexpPtr = objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { pattern = TclGetStringFromObj(objPtr, &length); regexpPtr = CompileRegexp(interp, pattern, length, flags); if (regexpPtr == NULL) { return NULL; |
︙ | ︙ | |||
597 598 599 600 601 602 603 | regexpPtr->refCount++; /* * Free the old representation and set our type. */ TclFreeIntRep(objPtr); | | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 | regexpPtr->refCount++; /* * Free the old representation and set our type. */ TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr; objPtr->typePtr = &tclRegexpType; } return (Tcl_RegExp) regexpPtr; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
745 746 747 748 749 750 751 | *---------------------------------------------------------------------- */ static void FreeRegexpInternalRep( Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */ { | | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 | *---------------------------------------------------------------------- */ static void FreeRegexpInternalRep( Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */ { TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1; /* * If this is the last reference to the regexp, free it. */ if (--(regexpRepPtr->refCount) <= 0) { FreeRegexp(regexpRepPtr); |
︙ | ︙ | |||
779 780 781 782 783 784 785 | */ static void DupRegexpInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { | | | | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 | */ static void DupRegexpInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1; regexpPtr->refCount++; copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->typePtr = &tclRegexpType; } /* *---------------------------------------------------------------------- * * SetRegexpFromAny -- |
︙ | ︙ |
Changes to generic/tclStringObj.c.
︙ | ︙ | |||
136 137 138 139 140 141 142 | #define stringAlloc(numChars) \ (String *) ckalloc((unsigned) STRING_SIZE(numChars) ) #define stringRealloc(ptr, numChars) \ (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define stringAttemptRealloc(ptr, numChars) \ (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define GET_STRING(objPtr) \ | | | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | #define stringAlloc(numChars) \ (String *) ckalloc((unsigned) STRING_SIZE(numChars) ) #define stringRealloc(ptr, numChars) \ (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define stringAttemptRealloc(ptr, numChars) \ (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define GET_STRING(objPtr) \ ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_STRING(objPtr, stringPtr) \ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) /* * TCL STRING GROWTH ALGORITHM * * When growing strings (during an append, for example), the following growth * algorithm is used: * |
︙ | ︙ |
Changes to generic/tclTestObj.c.
︙ | ︙ | |||
552 553 554 555 556 557 558 | if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) { return TCL_ERROR; } Tcl_GetIndexFromObjStruct(NULL, objv[1], tablePtr, sizeof(char *), "token", 0, &index); | | | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 | if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) { return TCL_ERROR; } Tcl_GetIndexFromObjStruct(NULL, objv[1], tablePtr, sizeof(char *), "token", 0, &index); indexRep = objv[1]->internalRep.twoPtrValue.ptr1; indexRep->index = index2; result = Tcl_GetIndexFromObjStruct(NULL, objv[1], tablePtr, sizeof(char *), "token", 0, &index); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), index); } return result; |
︙ | ︙ | |||
589 590 591 592 593 594 595 | * that its address is different for each index object. If we accidently * allocate a table at the same address as that cached in the index * object, clear out the object's cached state. */ if (objv[3]->typePtr != NULL && !strcmp("index", objv[3]->typePtr->name)) { | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 | * that its address is different for each index object. If we accidently * allocate a table at the same address as that cached in the index * object, clear out the object's cached state. */ if (objv[3]->typePtr != NULL && !strcmp("index", objv[3]->typePtr->name)) { indexRep = objv[3]->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr == (void *) argv) { TclFreeIntRep(objv[3]); } } result = Tcl_GetIndexFromObjStruct((setError? interp : NULL), objv[3], argv, sizeof(char *), "token", (allowAbbrev? 0 : TCL_EXACT), &index); |
︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 | case 5: /* length2 */ if (objc != 3) { goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); | | | 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 | case 5: /* length2 */ if (objc != 3) { goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1; length = (int) strPtr->allocated; } else { length = -1; } Tcl_SetIntObj(Tcl_GetObjResult(interp), length); break; case 6: /* set */ |
︙ | ︙ | |||
1301 1302 1303 1304 1305 1306 1307 | case 9: /* maxchars */ if (objc != 3) { goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); | | | 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 | case 9: /* maxchars */ if (objc != 3) { goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1; length = strPtr->maxChars; } else { length = -1; } Tcl_SetIntObj(Tcl_GetObjResult(interp), length); break; case 10: /* getunicode */ |
︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
︙ | ︙ | |||
569 570 571 572 573 574 575 | cachePtr->numObjects = numMove = NOBJALLOC; newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %d new objects", numMove); } while (--numMove >= 0) { objPtr = &newObjsPtr[numMove]; | | | | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 | cachePtr->numObjects = numMove = NOBJALLOC; newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %d new objects", numMove); } while (--numMove >= 0) { objPtr = &newObjsPtr[numMove]; objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; } } } /* * Pop the first object. */ objPtr = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1; cachePtr->numObjects--; return objPtr; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
617 618 619 620 621 622 623 | GETCACHE(cachePtr); /* * Get this thread's list and push on the free Tcl_Obj. */ | | | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 | GETCACHE(cachePtr); /* * Get this thread's list and push on the free Tcl_Obj. */ objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; cachePtr->numObjects++; /* * If the number of free objects has exceeded the high water mark, move * some blocks to the shared list. */ |
︙ | ︙ | |||
718 719 720 721 722 723 724 | /* * Find the last object to be moved; set the next one (the first one not * to be moved) as the first object in the 'from' cache. */ while (--numMove) { | | | | | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 | /* * Find the last object to be moved; set the next one (the first one not * to be moved) as the first object in the 'from' cache. */ while (--numMove) { objPtr = objPtr->internalRep.twoPtrValue.ptr1; } fromPtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1; /* * Move all objects as a block - they are already linked to each other, we * just have to update the first and last. */ objPtr->internalRep.twoPtrValue.ptr1 = toPtr->firstObjPtr; toPtr->firstObjPtr = fromFirstObjPtr; } /* *---------------------------------------------------------------------- * * Block2Ptr, Ptr2Block -- |
︙ | ︙ |
Changes to generic/tclVar.c.
︙ | ︙ | |||
471 472 473 474 475 476 477 478 479 480 481 482 483 484 | * is set to NULL. */ { Tcl_Obj *part2Ptr = NULL; Var *resPtr; if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); } resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, arrayPtrPtr); if (part2Ptr) { Tcl_DecrRefCount(part2Ptr); | > | 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 | * is set to NULL. */ { Tcl_Obj *part2Ptr = NULL; Var *resPtr; if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); Tcl_IncrRefCount(part2Ptr); } resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, arrayPtrPtr); if (part2Ptr) { Tcl_DecrRefCount(part2Ptr); |
︙ | ︙ | |||
1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 | const char *part2, /* If non-NULL, gives the name of an element * in the array part1. */ int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1); if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); } resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); Tcl_DecrRefCount(part1Ptr); if (part2Ptr) { Tcl_DecrRefCount(part2Ptr); | > > | 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 | const char *part2, /* If non-NULL, gives the name of an element * in the array part1. */ int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1); Tcl_IncrRefCount(part1Ptr); if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); Tcl_IncrRefCount(part2Ptr); } resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); Tcl_DecrRefCount(part1Ptr); if (part2Ptr) { Tcl_DecrRefCount(part2Ptr); |
︙ | ︙ | |||
2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 | int flags) /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ { int result; Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1); if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); } /* * Filter to pass through only the flags this interface supports. */ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); | > > | 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 | int flags) /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ { int result; Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1); Tcl_IncrRefCount(part1Ptr); if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); Tcl_IncrRefCount(part2Ptr); } /* * Filter to pass through only the flags this interface supports. */ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); |
︙ | ︙ | |||
3081 3082 3083 3084 3085 3086 3087 | searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, &searchPtr->search); Tcl_SetHashValue(hPtr, searchPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName)); return TCL_OK; } | | | 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 | searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, &searchPtr->search); Tcl_SetHashValue(hPtr, searchPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName)); return TCL_OK; } /* *---------------------------------------------------------------------- * * ArrayAnyMoreCmd -- * * This object-based function is invoked to process the "array anymore" * Tcl command. See the user documentation for details on what it does. |
︙ | ︙ | |||
3187 3188 3189 3190 3191 3192 3193 | gotValue = 0; break; } } Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[gotValue]); return TCL_OK; } | | | 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 | gotValue = 0; break; } } Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[gotValue]); return TCL_OK; } /* *---------------------------------------------------------------------- * * ArrayNextElementCmd -- * * This object-based function is invoked to process the "array * nextelement" Tcl command. See the user documentation for details on |
︙ | ︙ | |||
5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 | * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ { Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1); Tcl_Var var; var = ObjFindNamespaceVar(interp, namePtr, contextNsPtr, flags); Tcl_DecrRefCount(namePtr); return var; } static Tcl_Var ObjFindNamespaceVar( | > | 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 | * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ { Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1); Tcl_Var var; Tcl_IncrRefCount(namePtr); var = ObjFindNamespaceVar(interp, namePtr, contextNsPtr, flags); Tcl_DecrRefCount(namePtr); return var; } static Tcl_Var ObjFindNamespaceVar( |
︙ | ︙ | |||
5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 | * to check both possible search paths: from the specified namespace * context and from the global namespace. */ varPtr = NULL; if (simpleName != name) { simpleNamePtr = Tcl_NewStringObj(simpleName, -1); } else { simpleNamePtr = namePtr; } for (search = 0; (search < 2) && (varPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { varPtr = VarHashFindVar(&nsPtr[search]->varTable, simpleNamePtr); | > | 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 | * to check both possible search paths: from the specified namespace * context and from the global namespace. */ varPtr = NULL; if (simpleName != name) { simpleNamePtr = Tcl_NewStringObj(simpleName, -1); Tcl_IncrRefCount(simpleNamePtr); } else { simpleNamePtr = namePtr; } for (search = 0; (search < 2) && (varPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { varPtr = VarHashFindVar(&nsPtr[search]->varTable, simpleNamePtr); |
︙ | ︙ |
Changes to library/auto.tcl.
︙ | ︙ | |||
16 17 18 19 20 21 22 | # the information gets recomputed the next time it's needed. Also delete any # commands that are listed in the auto-load index. # # Arguments: # None. proc auto_reset {} { | > | | | | | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | # the information gets recomputed the next time it's needed. Also delete any # commands that are listed in the auto-load index. # # Arguments: # None. proc auto_reset {} { global auto_execs auto_index auto_path if {[array exists auto_index]} { foreach cmdName [array names auto_index] { set fqcn [namespace which $cmdName] if {$fqcn eq ""} { continue } rename $fqcn {} } } unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath if {[catch {llength $auto_path}]} { set auto_path [list [info library]] } elseif {[info library] ni $auto_path} { lappend auto_path [info library] } } # tcl_findLibrary -- # # This is a utility for extensions that searches for a library directory # using a canonical searching algorithm. A side effect is to source the # initialization script and set a global library variable. # # Arguments: # basename Prefix of the directory name, (e.g., "tk") # version Version number of the package, (e.g., "8.0") # patch Patchlevel of the package, (e.g., "8.0.3") # initScript Initialization script to source (e.g., tk.tcl) # enVarName environment variable to honor (e.g., TK_LIBRARY) # varName Global variable to set when done (e.g., tk_library) proc tcl_findLibrary {basename version patch initScript enVarName varName} { upvar #0 $varName the_library global auto_path env tcl_platform set dirs {} set errors {} # The C application may have hardwired a path, which we honor if {[info exists the_library] && $the_library ne ""} { |
︙ | ︙ | |||
79 80 81 82 83 84 85 | catch { lappend dirs [::${basename}::pkgconfig get scriptdir,runtime] } # 3. Relative to auto_path directories. This checks relative to the # Tcl library as well as allowing loading of libraries added to the # auto_path that is not relative to the core library or binary paths. | | < | | < | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | catch { lappend dirs [::${basename}::pkgconfig get scriptdir,runtime] } # 3. Relative to auto_path directories. This checks relative to the # Tcl library as well as allowing loading of libraries added to the # auto_path that is not relative to the core library or binary paths. foreach d $auto_path { lappend dirs [file join $d $basename$version] if {$tcl_platform(platform) eq "unix" && $tcl_platform(os) eq "Darwin"} { # 4. On MacOSX, check the Resources/Scripts subdir too lappend dirs [file join $d $basename$version Resources Scripts] } } # 3. Various locations relative to the executable # ../lib/foo1.0 (From bin directory in install hierarchy) |
︙ | ︙ |
Changes to library/init.tcl.
︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Copyright (c) 1998-1999 Scriptics Corporation. # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } package require -exact Tcl 9.0a0 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # Copyright (c) 1998-1999 Scriptics Corporation. # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # This test intentionally written in pre-7.5 Tcl if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } package require -exact Tcl 9.0a0 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: |
︙ | ︙ | |||
112 113 114 115 116 117 118 | } # Windows specific end of initialization if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { namespace eval tcl { proc EnvTraceProc {lo n1 n2 op} { | > | | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 | } # Windows specific end of initialization if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { namespace eval tcl { proc EnvTraceProc {lo n1 n2 op} { global env set x $env($n2) set env($lo) $x set env([string toupper $lo]) $x } proc InitWinEnv {} { global env tcl_platform foreach p [array names env] { set u [string toupper $p] if {$u ne $p} { switch -- $u { |
︙ | ︙ | |||
155 156 157 158 159 160 161 | if {[interp issafe]} { package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} } else { # Set up search for Tcl Modules (TIP #189). # and setup platform specific unknown package handlers | | | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | if {[interp issafe]} { package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} } else { # Set up search for Tcl Modules (TIP #189). # and setup platform specific unknown package handlers if {$tcl_platform(os) eq "Darwin" && $tcl_platform(platform) eq "unix"} { package unknown {::tcl::tm::UnknownHandler \ {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}} } else { package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} } # Set up the 'clock' ensemble |
︙ | ︙ | |||
229 230 231 232 233 234 235 | # # Arguments: # args - A list whose elements are the words of the original # command, including the command name. proc unknown args { variable ::tcl::UnknownPending | | < | | | | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 | # # Arguments: # args - A list whose elements are the words of the original # command, including the command name. proc unknown args { variable ::tcl::UnknownPending global auto_noexec auto_noload env tcl_interactive errorInfo errorCode if {[info exists errorInfo]} { set savedErrorInfo $errorInfo } if {[info exists errorCode]} { set savedErrorCode $errorCode } set name [lindex $args 0] if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. # |
︙ | ︙ | |||
267 268 269 270 271 272 273 | if {$msg} { if {[info exists savedErrorCode]} { set ::errorCode $savedErrorCode } else { unset -nocomplain ::errorCode } if {[info exists savedErrorInfo]} { | | | | | | | | | | | | | | 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 | if {$msg} { if {[info exists savedErrorCode]} { set ::errorCode $savedErrorCode } else { unset -nocomplain ::errorCode } if {[info exists savedErrorInfo]} { set errorInfo $savedErrorInfo } else { unset -nocomplain errorInfo } set code [catch {uplevel 1 $args} msg opts] if {$code == 1} { # # Compute stack trace contribution from the [uplevel]. # Note the dependence on how Tcl_AddErrorInfo, etc. # construct the stack trace. # set errInfo [dict get $opts -errorinfo] set errCode [dict get $opts -errorcode] set cinfo $args if {[string bytelength $cinfo] > 150} { set cinfo [string range $cinfo 0 150] while {[string bytelength $cinfo] > 150} { set cinfo [string range $cinfo 0 end-1] } append cinfo ... } append cinfo "\"\n (\"uplevel\" body line 1)" append cinfo "\n invoked from within" append cinfo "\n\"uplevel 1 \$args\"" # # Try each possible form of the stack trace # and trim the extra contribution from the matching case # set expect "$msg\n while executing\n\"$cinfo" if {$errInfo eq $expect} { # # The stack has only the eval from the expanded command # Do not generate any stack trace here. # dict unset opts -errorinfo dict incr opts -level return -options $opts $msg } # # Stack trace is nested, trim off just the contribution # from the extra "eval" of $args due to the "catch" above. # set expect "\n invoked from within\n\"$cinfo" set exlen [string length $expect] set eilen [string length $errInfo] set i [expr {$eilen - $exlen - 1}] set einfo [string range $errInfo 0 $i] # # For now verify that $errInfo consists of what we are about # to return plus what we expected to trim off. # if {$errInfo ne "$einfo$expect"} { error "Tcl bug: unexpected stack trace in \"unknown\"" {} \ [list CORE UNKNOWN BADTRACE $einfo $expect $errInfo] } return -code error -errorcode $errCode \ -errorinfo $einfo $msg } else { dict incr opts -level return -options $opts $msg } } } if {([info level] == 1) && ([info script] eq "") && [info exists tcl_interactive] && $tcl_interactive} { if {![info exists auto_noexec]} { set new [auto_execok $name] if {$new ne ""} { set redir "" if {[namespace which -command console] eq ""} { set redir ">&@stdout <@stdin" |
︙ | ︙ | |||
784 785 786 787 788 789 790 | # working directory, the directories '.', '..' # can be returned in various combinations. Anyway, # if any other file is returned, we must signal an error. set existing [glob -nocomplain -directory $dest * .*] lappend existing {*}[glob -nocomplain -directory $dest \ -type hidden * .*] foreach s $existing { | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 | # working directory, the directories '.', '..' # can be returned in various combinations. Anyway, # if any other file is returned, we must signal an error. set existing [glob -nocomplain -directory $dest * .*] lappend existing {*}[glob -nocomplain -directory $dest \ -type hidden * .*] foreach s $existing { if {[file tail $s] ni {. ..}} { return -code error "error $action \"$src\" to\ \"$dest\": file already exists" } } } } else { if {[string first $nsrc $ndest] != -1} { set srclen [expr {[llength [file split $nsrc]] - 1}] set ndest [lindex [file split $ndest] $srclen] if {$ndest eq [file tail $nsrc]} { return -code error "error $action \"$src\" to\ \"$dest\": trying to rename a volume or move a directory\ into itself" } } file mkdir $dest } # Have to be careful to capture both visible and hidden files. # We will also be more generous to the file system and not # assume the hidden and non-hidden lists are non-overlapping. # # On Unix 'hidden' files begin with '.'. On other platforms # or filesystems hidden files may have other interpretations. set filelist [concat [glob -nocomplain -directory $src *] \ [glob -nocomplain -directory $src -types hidden *]] foreach s [lsort -unique $filelist] { if {[file tail $s] ni {. ..}} { file copy -force -- $s [file join $dest [file tail $s]] } } return } |
Changes to library/package.tcl.
︙ | ︙ | |||
394 395 396 397 398 399 400 | append index "# information so that packages will be loaded automatically\n" append index "# in response to \"package require\" commands. When this\n" append index "# script is sourced, the variable \$dir must contain the\n" append index "# full path name of this file's directory.\n" foreach pkg [lsort [array names files]] { set cmd {} | | < < | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 | append index "# information so that packages will be loaded automatically\n" append index "# in response to \"package require\" commands. When this\n" append index "# script is sourced, the variable \$dir must contain the\n" append index "# full path name of this file's directory.\n" foreach pkg [lsort [array names files]] { set cmd {} lassign $pkg name version lappend cmd ::tcl::Pkg::Create -name $name -version $version foreach spec [lsort -index 0 $files($pkg)] { foreach {file type procs} $spec { if {$direct} { set procs {} } lappend cmd "-$type" [list $file $procs] |
︙ | ︙ | |||
543 544 545 546 547 548 549 | # $index now points to the first element of $auto_path that has # changed, or the beginning if $auto_path has changed length Scan the # new elements of $auto_path for directories to add to $use_path. # Don't add directories we've already seen, or ones already on the # $use_path. foreach dir [lrange $auto_path $index end] { | | < | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 | # $index now points to the first element of $auto_path that has # changed, or the beginning if $auto_path has changed length Scan the # new elements of $auto_path for directories to add to $use_path. # Don't add directories we've already seen, or ones already on the # $use_path. foreach dir [lrange $auto_path $index end] { if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { lappend use_path $dir } } set old_path $auto_path } } |
︙ | ︙ | |||
627 628 629 630 631 632 633 | # $index now points to the first element of $auto_path that has # changed, or the beginning if $auto_path has changed length Scan the # new elements of $auto_path for directories to add to $use_path. # Don't add directories we've already seen, or ones already on the # $use_path. foreach dir [lrange $auto_path $index end] { | | < | 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 | # $index now points to the first element of $auto_path that has # changed, or the beginning if $auto_path has changed length Scan the # new elements of $auto_path for directories to add to $use_path. # Don't add directories we've already seen, or ones already on the # $use_path. foreach dir [lrange $auto_path $index end] { if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { lappend use_path $dir } } set old_path $auto_path } } |
︙ | ︙ | |||
680 681 682 683 684 685 686 | # process arguments set len [llength $args] if {$len < 6} { error $err(wrongNumArgs) } # Initialize parameters | | < < < | 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 | # process arguments set len [llength $args] if {$len < 6} { error $err(wrongNumArgs) } # Initialize parameters array set opts {-name {} -version {} -source {} -load {}} # process parameters for {set i 0} {$i < $len} {incr i} { set flag [lindex $args $i] incr i switch -glob -- $flag { "-name" - |
︙ | ︙ | |||
731 732 733 734 735 736 737 | set cmdList {} set lazyFileList {} # Handle -load and -source specs foreach key {load source} { foreach filespec $opts(-$key) { | | < | < < < < | | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 | set cmdList {} set lazyFileList {} # Handle -load and -source specs foreach key {load source} { foreach filespec $opts(-$key) { lassign $filespec filename proclist if { [llength $proclist] == 0 } { set cmd "\[list $key \[file join \$dir [list $filename]\]\]" lappend cmdList $cmd } else { lappend lazyFileList [list $filename $key $proclist] } } } |
︙ | ︙ |
Changes to library/platform/pkgIndex.tcl.
|
| | | 1 2 3 | package ifneeded platform 1.0.11 [list source [file join $dir platform.tcl]] package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]] |
Changes to library/platform/platform.tcl.
︙ | ︙ | |||
252 253 254 255 256 257 258 | # Try executing the library first. This should suceed # for a glibc library, and return the version # information. if {![catch { set vdata [lindex [split [exec $libc] \n] 0] }]} { | | | 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 | # Try executing the library first. This should suceed # for a glibc library, and return the version # information. if {![catch { set vdata [lindex [split [exec $libc] \n] 0] }]} { regexp {version ([0-9]+(\.[0-9]+)*), by} $vdata -> v foreach {major minor} [split $v .] break set v glibc${major}.${minor} return 1 } else { # We had trouble executing the library. We are now # inspecting its name to determine the version # number. This code by Larry McVoy. |
︙ | ︙ | |||
364 365 366 367 368 369 370 | return $res } # ### ### ### ######### ######### ######### ## Ready | | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 | return $res } # ### ### ### ######### ######### ######### ## Ready package provide platform 1.0.11 # ### ### ### ######### ######### ######### ## Demo application if {[info exists argv0] && ($argv0 eq [info script])} { puts ==================================== parray tcl_platform |
︙ | ︙ |
Changes to library/tcltest/tcltest.tcl.
︙ | ︙ | |||
80 81 82 83 84 85 86 | # Results # The path is modified in place. # # Side Effects: # None. # proc normalizePath {pathVar} { | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | # Results # The path is modified in place. # # Side Effects: # None. # proc normalizePath {pathVar} { upvar 1 $pathVar path set oldpwd [pwd] catch {cd $path} set path [pwd] cd $oldpwd return $path } |
︙ | ︙ | |||
243 244 245 246 247 248 249 | # After successful filling, turn this into a no-op. proc FillFilesExisted args {} } # Kept only for compatibility Default constraintsSpecified {} AcceptList | | | | | | | | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | # After successful filling, turn this into a no-op. proc FillFilesExisted args {} } # Kept only for compatibility Default constraintsSpecified {} AcceptList trace add variable constraintsSpecified read [namespace code { set constraintsSpecified [array names testConstraints] ;#}] # tests that use threads need to know which is the main thread Default mainThread 1 variable mainThread if {[info commands thread::id] ne {}} { set mainThread [thread::id] } elseif {[info commands testthread] ne {}} { set mainThread [testthread id] } # Set workingDirectory to [pwd]. The default output directory for # Tcl tests is the working directory. Whenever this value changes # change to that directory. variable workingDirectory trace add variable workingDirectory write \ [namespace code {cd $workingDirectory ;#}] Default workingDirectory [pwd] AcceptAbsolutePath proc workingDirectory { {dir ""} } { variable workingDirectory if {[llength [info level 0]] == 1} { return $workingDirectory } set workingDirectory [AcceptAbsolutePath $dir] } # Set the location of the execuatble Default tcltest [info nameofexecutable] trace add variable tcltest write [namespace code {testConstraint stdio \ [eval [ConstraintInitializer stdio]] ;#}] # save the platform information so it can be restored later Default originalTclPlatform [array get ::tcl_platform] # If a core file exists, save its modification time. if {[file exists [file join [workingDirectory] core]]} { |
︙ | ︙ | |||
400 401 402 403 404 405 406 | set ChannelsWeOpened($outputChannel) 1 # If we created the file in [temporaryDirectory], then # [cleanupTests] will delete it, unless we claim it was # already there. set outdir [normalizePath [file dirname \ [file join [pwd] $filename]]] | | | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 | set ChannelsWeOpened($outputChannel) 1 # If we created the file in [temporaryDirectory], then # [cleanupTests] will delete it, unless we claim it was # already there. set outdir [normalizePath [file dirname \ [file join [pwd] $filename]]] if {$outdir eq [temporaryDirectory]} { variable filesExisted FillFilesExisted set filename [file tail $filename] if {$filename ni $filesExisted} { lappend filesExisted $filename } } } } return $outputChannel } |
︙ | ︙ | |||
444 445 446 447 448 449 450 | set ChannelsWeOpened($errorChannel) 1 # If we created the file in [temporaryDirectory], then # [cleanupTests] will delete it, unless we claim it was # already there. set outdir [normalizePath [file dirname \ [file join [pwd] $filename]]] | | | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 | set ChannelsWeOpened($errorChannel) 1 # If we created the file in [temporaryDirectory], then # [cleanupTests] will delete it, unless we claim it was # already there. set outdir [normalizePath [file dirname \ [file join [pwd] $filename]]] if {$outdir eq [temporaryDirectory]} { variable filesExisted FillFilesExisted set filename [file tail $filename] if {$filename ni $filesExisted} { lappend filesExisted $filename } } } } return $errorChannel } |
︙ | ︙ | |||
530 531 532 533 534 535 536 | one of $values" } 1 { return [lindex $match 0] } default { # Exact match trumps ambiguity | | > | | | | | | | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 | one of $values" } 1 { return [lindex $match 0] } default { # Exact match trumps ambiguity if {$option in $match} { return $option } set values [join [lrange $match 0 end-1] ", "] append values ", or [lindex $match end]" return -code error "ambiguous option $option:\ could match $values" } } } proc EstablishAutoConfigureTraces {} { variable OptionControlledVariables foreach varName [concat $OptionControlledVariables Option] { variable $varName trace add variable $varName read [namespace code { ProcessCmdLineArgs ;#}] } } proc RemoveAutoConfigureTraces {} { variable OptionControlledVariables foreach varName [concat $OptionControlledVariables Option] { variable $varName foreach pair [trace info variable $varName] { lassign $pair op cmd if {($op eq "read") && [string match *ProcessCmdLineArgs* $cmd]} { trace remove variable $varName $op $cmd } } } # Once the traces are removed, this can become a no-op proc RemoveAutoConfigureTraces {} {} } |
︙ | ︙ | |||
694 695 696 697 698 699 700 | foreach c $Option(-constraints) { testConstraint $c 1 } } Option -constraints {} { Do not skip the listed constraints listed in -constraints. } AcceptList | | | | | | | | | | | | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 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 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 | foreach c $Option(-constraints) { testConstraint $c 1 } } Option -constraints {} { Do not skip the listed constraints listed in -constraints. } AcceptList trace add variable Option(-constraints) write \ [namespace code {SetSelectedConstraints ;#}] # Don't run only the "-constraint" specified tests by default proc ClearUnselectedConstraints args { variable Option variable testConstraints if {!$Option(-limitconstraints)} {return} foreach c [array names testConstraints] { if {$c ni $Option(-constraints)} { testConstraint $c 0 } } } Option -limitconstraints 0 { whether to run only tests with the constraints } AcceptBoolean limitConstraints trace add variable Option(-limitconstraints) write \ [namespace code {ClearUnselectedConstraints ;#}] # A test application has to know how to load the tested commands # into the interpreter. Option -load {} { Specifies the script to load the tested commands. } AcceptScript loadScript # Default is to run each test file in a separate process Option -singleproc 0 { whether to run all tests in one process } AcceptBoolean singleProcess proc AcceptTemporaryDirectory { directory } { set directory [AcceptAbsolutePath $directory] if {![file exists $directory]} { file mkdir $directory } set directory [AcceptDirectory $directory] if {![file writable $directory]} { if {[workingDirectory] eq $directory} { # Special exception: accept the default value # even if the directory is not writable return $directory } return -code error "\"$directory\" is not writeable" } return $directory } # Directory where files should be created Option -tmpdir [workingDirectory] { Save temporary files in the specified directory. } AcceptTemporaryDirectory temporaryDirectory trace add variable Option(-tmpdir) write \ [namespace code {normalizePath Option(-tmpdir) ;#}] # Tests should not rely on the current working directory. # Files that are part of the test suite should be accessed relative # to [testsDirectory] Option -testdir [workingDirectory] { Search tests in the specified directory. } AcceptDirectory testsDirectory trace add variable Option(-testdir) write \ [namespace code {normalizePath Option(-testdir) ;#}] proc AcceptLoadFile { file } { if {$file eq {}} {return $file} set file [file join [temporaryDirectory] $file] return [AcceptReadable $file] } proc ReadLoadScript {args} { variable Option if {$Option(-loadfile) eq {}} {return} set tmp [open $Option(-loadfile) r] loadScript [read $tmp] close $tmp } Option -loadfile {} { Read the script to load the tested commands from the specified file. } AcceptLoadFile loadFile trace add variable Option(-loadfile) write [namespace code ReadLoadScript] proc AcceptOutFile { file } { if {[string equal stderr $file]} {return $file} if {[string equal stdout $file]} {return $file} return [file join [temporaryDirectory] $file] } # output goes to stdout by default Option -outfile stdout { Send output from test runs to the specified file. } AcceptOutFile outputFile trace add variable Option(-outfile) write \ [namespace code {outputChannel $Option(-outfile) ;#}] # errors go to stderr by default Option -errfile stderr { Send errors from test runs to the specified file. } AcceptOutFile errorFile trace add variable Option(-errfile) write \ [namespace code {errorChannel $Option(-errfile) ;#}] proc loadIntoSlaveInterpreter {slave args} { variable Version interp eval $slave [package ifneeded tcltest $Version] interp eval $slave "tcltest::configure {*}{$args}" interp alias $slave ::tcltest::ReportToMaster \ |
︙ | ︙ | |||
873 874 875 876 877 878 879 | # None. # proc tcltest::DebugPArray {level arrayvar} { variable debug if {$debug >= $level} { | | | 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 | # None. # proc tcltest::DebugPArray {level arrayvar} { variable debug if {$debug >= $level} { catch {upvar 1 $arrayvar $arrayvar} parray $arrayvar } return } # Define our own [parray] in ::tcltest that will inherit use of the [puts] # defined in ::tcltest. NOTE: Ought to construct with [info args] and |
︙ | ︙ | |||
957 958 959 960 961 962 963 | if {[llength [info level 0]] == 2} { return $testConstraints($constraint) } # Check for boolean values if {[catch {expr {$value && $value}} msg]} { return -code error $msg } | | < | 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 | if {[llength [info level 0]] == 2} { return $testConstraints($constraint) } # Check for boolean values if {[catch {expr {$value && $value}} msg]} { return -code error $msg } if {[limitConstraints] && ($constraint ni $Option(-constraints))} { set value 0 } set testConstraints($constraint) $value } # tcltest::interpreter -- # |
︙ | ︙ | |||
982 983 984 985 986 987 988 | # None. proc tcltest::interpreter { {interp ""} } { variable tcltest if {[llength [info level 0]] == 1} { return $tcltest } | < < < | < | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 | # None. proc tcltest::interpreter { {interp ""} } { variable tcltest if {[llength [info level 0]] == 1} { return $tcltest } set tcltest $interp } ##################################################################### # tcltest::AddToSkippedBecause -- # # Increments the variable used to track how many tests were |
︙ | ︙ | |||
1051 1052 1053 1054 1055 1056 1057 | } else { # Print up to 80 characters on the first line, including the # InitialMessage. set beginningIndex [string last " " [string range $errorMsg 0 \ [expr {80 - $InitialMsgLen}]]] puts [errorChannel] [string range $errorMsg 0 $beginningIndex] | | | 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 | } else { # Print up to 80 characters on the first line, including the # InitialMessage. set beginningIndex [string last " " [string range $errorMsg 0 \ [expr {80 - $InitialMsgLen}]]] puts [errorChannel] [string range $errorMsg 0 $beginningIndex] while {$beginningIndex ne "end"} { puts -nonewline [errorChannel] \ [string repeat " " $InitialMsgLen] if {($endingIndex - $beginningIndex) < (80 - $InitialMsgLen)} { puts [errorChannel] [string trim \ [string range $errorMsg $beginningIndex end]] break |
︙ | ︙ | |||
1104 1105 1106 1107 1108 1109 1110 | # Side effects: # sets testConstraints($n2) to 0 if it's referenced but never # before used proc tcltest::SafeFetch {n1 n2 op} { variable testConstraints DebugPuts 3 "entering SafeFetch $n1 $n2 $op" | | | 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 | # Side effects: # sets testConstraints($n2) to 0 if it's referenced but never # before used proc tcltest::SafeFetch {n1 n2 op} { variable testConstraints DebugPuts 3 "entering SafeFetch $n1 $n2 $op" if {$n2 eq {}} {return} if {![info exists testConstraints($n2)]} { if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} { testConstraint $n2 0 } } } |
︙ | ︙ | |||
1249 1250 1251 1252 1253 1254 1255 | # Some tests can only be run if the installation came from a CD # image instead of a web image. Some tests must be skipped if you # are running as root on Unix. Other tests can only be run if you # are running as root on Unix. ConstraintInitializer root {expr \ | | | < | | 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 | # Some tests can only be run if the installation came from a CD # image instead of a web image. Some tests must be skipped if you # are running as root on Unix. Other tests can only be run if you # are running as root on Unix. ConstraintInitializer root {expr \ {($::tcl_platform(platform) eq "unix") && ($::tcl_platform(user) in {root {}})}} ConstraintInitializer notRoot {expr {![testConstraint root]}} # Set nonBlockFiles constraint: 1 means this platform supports # setting files into nonblocking mode. ConstraintInitializer nonBlockFiles { set code [expr {[catch {set f [open defs r]}] || [catch {chan configure $f -blocking off}]}] catch {close $f} set code } # Set asyncPipeClose constraint: 1 means this platform supports # async flush and async close on a pipe. # |
︙ | ︙ | |||
1285 1286 1287 1288 1289 1290 1291 | ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} # Test to see if execed commands such as cat, echo, rm and so forth # are present on this machine. ConstraintInitializer unixExecs { set code 1 | | | | 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 | ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} # Test to see if execed commands such as cat, echo, rm and so forth # are present on this machine. ConstraintInitializer unixExecs { set code 1 if {$::tcl_platform(platform) eq "macintosh"} { set code 0 } if {$::tcl_platform(platform) eq "windows"} { if {[catch { set file _tcl_test_remove_me.txt makeFile {hello} $file }]} { set code 0 } elseif { [catch {exec cat $file}] || |
︙ | ︙ | |||
1382 1383 1384 1385 1386 1387 1388 | append msg "?-help? ?flag value? ... \n" append msg "Available flags (and valid input values) are:" set max 0 set allOpts [concat -help [Configure]] foreach opt $allOpts { set foo [Usage $opt] | | | 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 | append msg "?-help? ?flag value? ... \n" append msg "Available flags (and valid input values) are:" set max 0 set allOpts [concat -help [Configure]] foreach opt $allOpts { set foo [Usage $opt] lassign $foo x type($opt) usage($opt) set line($opt) " $opt $type($opt) " set length($opt) [string length $line($opt)] if {$length($opt) > $max} {set max $length($opt)} } set rest [expr {72 - $max}] foreach opt $allOpts { append msg \n$line($opt) |
︙ | ︙ | |||
1406 1407 1408 1409 1410 1411 1412 | append msg [string range $u 0 [expr {$break - 1}]] set u [string trim [string range $u $break end]] append msg \n[string repeat " " $max] } append msg $u } return $msg\n | | | 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 | append msg [string range $u 0 [expr {$break - 1}]] set u [string trim [string range $u $break end]] append msg \n[string repeat " " $max] } append msg $u } return $msg\n } elseif {$option eq "-help"} { return [list -help "" "Display this usage information."] } else { set type [lindex [info args $Verify($option)] 0] return [list $option $type $Usage($option)] } } |
︙ | ︙ | |||
1432 1433 1434 1435 1436 1437 1438 | # flagArray # # Side effects: # None. proc tcltest::ProcessFlags {flagArray} { # Process -help first | | | | | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 | # flagArray # # Side effects: # None. proc tcltest::ProcessFlags {flagArray} { # Process -help first if {"-help" in $flagArray} { PrintUsageInfo exit 1 } if {[llength $flagArray] == 0} { RemoveAutoConfigureTraces } else { set args $flagArray while {[llength $args] > 1 && [catch {configure {*}$args} msg]} { # Something went wrong parsing $args for tcltest options # Check whether the problem is "unknown option" if {[regexp {^unknown option (\S+):} $msg -> option]} { # Could be this is an option the Hook knows about set moreOptions [processCmdLineArgsAddFlagsHook] if {$option ni $moreOptions} { # Nope. Report the error, including additional options, # but keep going if {[llength $moreOptions]} { append msg ", " append msg [join [lrange $moreOptions 0 end-1] ", "] append msg "or [lindex $moreOptions end]" } Warn $msg } } else { # error is something other than "unknown option" # notify user of the error; and exit puts [errorChannel] $msg exit 1 } # To recover, find that unknown option and remove up to it. # then retry while {[lindex $args 0] ne $option} { set args [lrange $args 2 end] } set args [lrange $args 2 end] } if {[llength $args] == 1} { puts [errorChannel] \ "missing value for option [lindex $args 0]" |
︙ | ︙ | |||
1573 1574 1575 1576 1577 1578 1579 | # Only the string to be printed is specified append outData [lindex $args 0]\n return # return [Puts [lindex $args 0]] } 2 { # Either -nonewline or channelId has been specified | | | | < | < | 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 | # Only the string to be printed is specified append outData [lindex $args 0]\n return # return [Puts [lindex $args 0]] } 2 { # Either -nonewline or channelId has been specified if {[lindex $args 0] eq "-nonewline"} { append outData [lindex $args end] return # return [Puts -nonewline [lindex $args end]] } else { set channel [lindex $args 0] set newline \n } } 3 { if {[lindex $args 0] eq "-nonewline"} { # Both -nonewline and channelId are specified, unless # it's an error. -nonewline is supposed to be argv[0]. set channel [lindex $args 1] set newline "" } } } if {[info exists channel]} { if {$channel in [list [[namespace parent]::outputChannel] stdout]} { append outData [lindex $args end]$newline return } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} { append errData [lindex $args end]$newline return } } # If we haven't returned by now, we don't know how to handle the # input. Let puts handle it. |
︙ | ︙ | |||
1767 1768 1769 1770 1771 1772 1773 | } else { # Take everything up to the end of the argList. set text $argList set word {} set argList {} } | | | 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 | } else { # Take everything up to the end of the argList. set text $argList set word {} set argList {} } if {$token ne {}} { # If we saw a word with quote before, then there is a # multi-word token starting with that word. In this case, # add the text and the current word to this token. append token $text $word } else { # Add the text to the result. There is no need to parse # the text because it couldn't be a part of any multi-word |
︙ | ︙ | |||
1874 1875 1876 1877 1878 1879 1880 | FillFilesExisted incr testLevel # Pre-define everything to null except output and errorOutput. We # determine whether or not to trap output based on whether or not # these variables (output & errorOutput) are defined. | | < < < | < | | | 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 | FillFilesExisted incr testLevel # Pre-define everything to null except output and errorOutput. We # determine whether or not to trap output based on whether or not # these variables (output & errorOutput) are defined. lassign {} constraints setup cleanup body result returnCodes match # Set the default match mode set match exact # Set the default match values for return codes (0 is the standard # expected return value if everything went well; 2 represents # 'return' being used in the test script). set returnCodes [list 0 2] # The old test format can't have a 3rd argument (constraints or # script) that starts with '-'. if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { if {[llength $args] == 1} { set list [SubstArguments [lindex $args 0]] foreach {element value} $list { set testAttributes($element) $value } foreach item {constraints match setup body cleanup \ result returnCodes output errorOutput} { if {[info exists testAttributes(-$item)]} { set testAttributes(-$item) [uplevel 1 \ ::concat $testAttributes(-$item)] } } } else { array set testAttributes $args } set validFlags {-setup -cleanup -body -result -returnCodes \ -match -output -errorOutput -constraints} foreach flag [array names testAttributes] { if {$flag ni $validFlags} { incr testLevel -1 set sorted [lsort $validFlags] set options [join [lrange $sorted 0 end-1] ", "] append options ", or [lindex $sorted end]" return -code error "bad option \"$flag\": must be $options" } } # store whatever the user gave us foreach item [array names testAttributes] { set [string trimleft $item "-"] $testAttributes($item) } # Check the values supplied for -match variable CustomMatch if {$match ni [array names CustomMatch]} { incr testLevel -1 set sorted [lsort [array names CustomMatch]] set values [join [lrange $sorted 0 end-1] ", "] append values ", or [lindex $sorted end]" return -code error "bad -match value \"$match\":\ must be $values" } |
︙ | ︙ | |||
1991 1992 1993 1994 1995 1996 1997 | set command [list [namespace origin RunTest] $name $body] if {[info exists output] || [info exists errorOutput]} { set testResult [uplevel 1 [list [namespace origin Eval] $command 0]] } else { set testResult [uplevel 1 [list [namespace origin Eval] $command 1]] } | | | 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 | set command [list [namespace origin RunTest] $name $body] if {[info exists output] || [info exists errorOutput]} { set testResult [uplevel 1 [list [namespace origin Eval] $command 0]] } else { set testResult [uplevel 1 [list [namespace origin Eval] $command 1]] } lassign $testResult actualAnswer returnCode if {$returnCode == 1} { set errorInfo(body) $::errorInfo set errorCode(body) $::errorCode } } # Always run the cleanup script |
︙ | ︙ | |||
2027 2028 2029 2030 2031 2032 2033 | } else { set coreFailure 1 } if {([preserveCore] > 1) && ($coreFailure)} { append coreMsg "\nMoving file to:\ [file join [temporaryDirectory] core-$name]" | | | | | 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 | } else { set coreFailure 1 } if {([preserveCore] > 1) && ($coreFailure)} { append coreMsg "\nMoving file to:\ [file join [temporaryDirectory] core-$name]" catch {file rename -force -- \ [file join [workingDirectory] core] \ [file join [temporaryDirectory] core-$name] } msg if {$msg ne {}} { append coreMsg "\nError:\ Problem renaming core file: $msg" } } } } # check if the return code matched the expected return code set codeFailure 0 if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. set outputFailure 0 variable outData |
︙ | ︙ | |||
2120 2121 2122 2123 2124 2125 2126 | set testLine [dict get $testFrame line] } else { set testFile [file normalize [uplevel 1 {info script}]] if {[file readable $testFile]} { set testFd [open $testFile r] set testLine [expr {[lsearch -regexp \ [split [read $testFd] "\n"] \ | | | 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 | set testLine [dict get $testFrame line] } else { set testFile [file normalize [uplevel 1 {info script}]] if {[file readable $testFile]} { set testFd [open $testFile r] set testLine [expr {[lsearch -regexp \ [split [read $testFd] "\n"] \ "^\[ \t\]*test [string map {. \\.} $name] "] + 1}] close $testFd } } if {[info exists testLine]} { puts [outputChannel] "$testFile:$testLine: error: test failed:\ $name [string trim $description]" } |
︙ | ︙ | |||
2165 2166 2167 2168 2169 2170 2171 | 4 { set msg "Test generated continue exception" } default { set msg "Test generated exception" } } puts [outputChannel] "---- $msg; Return code was: $returnCode" puts [outputChannel] "---- Return code should have been\ one of: $returnCodes" if {[IsVerbose error]} { | | | 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 | 4 { set msg "Test generated continue exception" } default { set msg "Test generated exception" } } puts [outputChannel] "---- $msg; Return code was: $returnCode" puts [outputChannel] "---- Return code should have been\ one of: $returnCodes" if {[IsVerbose error]} { if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { puts [outputChannel] "---- errorInfo: $errorInfo(body)" puts [outputChannel] "---- errorCode: $errorCode(body)" } } } if {$outputFailure} { if {$outputCompare} { |
︙ | ︙ | |||
2246 2247 2248 2249 2250 2251 2252 | if {!$ok} { if {$testLevel == 1} { incr numTests(Skipped) DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch} } return 1 } | | | 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 | if {!$ok} { if {$testLevel == 1} { incr numTests(Skipped) DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch} } return 1 } if {$constraints eq {}} { # If we're limited to the listed constraints and there aren't # any listed, then we shouldn't run the test. if {[limitConstraints]} { AddToSkippedBecause userSpecifiedLimitConstraint if {$testLevel == 1} { incr numTests(Skipped) } |
︙ | ︙ | |||
2397 2398 2399 2400 2401 2402 2403 | # workingDirectory that were not pre-existing, and associate them # with the test file that created them. if {!$calledFromAllFile} { foreach file $filesMade { if {[file exists $file]} { DebugDo 1 {Warn "cleanupTests deleting $file..."} | | | | 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 | # workingDirectory that were not pre-existing, and associate them # with the test file that created them. if {!$calledFromAllFile} { foreach file $filesMade { if {[file exists $file]} { DebugDo 1 {Warn "cleanupTests deleting $file..."} catch {file delete -force -- $file} } } set currentFiles {} foreach file [glob -nocomplain \ -directory [temporaryDirectory] *] { lappend currentFiles [file tail $file] } set newFiles {} foreach file $currentFiles { if {$file ni $filesExisted} { lappend newFiles $file } } set filesExisted $currentFiles if {[llength $newFiles] > 0} { set createdNewFiles($testFileName) $newFiles } |
︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 | } } else { # if we're deferring stat-reporting until all files are sourced, # then add current file to failFile list if any tests in this # file failed | | < | 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 | } } else { # if we're deferring stat-reporting until all files are sourced, # then add current file to failFile list if any tests in this # file failed if {$currentFailure && ($testFileName ni $failFiles)} { lappend failFiles $testFileName } set currentFailure false # restore the environment to the state it was in before this package # was loaded |
︙ | ︙ | |||
2551 2552 2553 2554 2555 2556 2557 | if {[file exists [file join [workingDirectory] core]]} { if {[preserveCore] > 1} { puts "rename core file (> 1)" puts [outputChannel] "produced core file! \ Moving file to: \ [file join [temporaryDirectory] core-$testFileName]" | | | | 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 | if {[file exists [file join [workingDirectory] core]]} { if {[preserveCore] > 1} { puts "rename core file (> 1)" puts [outputChannel] "produced core file! \ Moving file to: \ [file join [temporaryDirectory] core-$testFileName]" catch {file rename -force -- \ [file join [workingDirectory] core] \ [file join [temporaryDirectory] core-$testFileName] } msg if {$msg ne {}} { PrintError "Problem renaming file: $msg" } } else { # Print a message if there is a core file and (1) there # previously wasn't one or (2) the new one is different # from the old one. |
︙ | ︙ | |||
2633 2634 2635 2636 2637 2638 2639 | set skipFileList [concat $skipFileList \ [glob -directory $directory -types {b c f p s} \ -nocomplain -- $skip]] } # Add to result list all files in match list and not in skip list foreach file $matchFileList { | | | 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 | set skipFileList [concat $skipFileList \ [glob -directory $directory -types {b c f p s} \ -nocomplain -- $skip]] } # Add to result list all files in match list and not in skip list foreach file $matchFileList { if {$file ni $skipFileList} { lappend matchingFiles $file } } } if {[llength $matchingFiles] == 0} { PrintError "No test files remain after applying your match and\ |
︙ | ︙ | |||
2680 2681 2682 2683 2684 2685 2686 | # Now step through the matching directories, prune out the skipped ones # as you go. set matchDirs [list] foreach pattern [matchDirectories] { foreach path [glob -directory $rootdir -types d -nocomplain -- \ $pattern] { | | | 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 | # Now step through the matching directories, prune out the skipped ones # as you go. set matchDirs [list] foreach pattern [matchDirectories] { foreach path [glob -directory $rootdir -types d -nocomplain -- \ $pattern] { if {$path ni $skipDirs} { set matchDirs [concat $matchDirs [GetMatchingDirectories $path]] if {[file exists [file join $path all.tcl]]} { lappend matchDirs $path } } } } |
︙ | ︙ | |||
2733 2734 2735 2736 2737 2738 2739 | puts [outputChannel] "Tests located in: [testsDirectory]" puts [outputChannel] "Tests running in: [workingDirectory]" puts [outputChannel] "Temporary files stored in\ [temporaryDirectory]" # [file system] first available in Tcl 8.4 if {![catch {file system [testsDirectory]} result] | | | 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 | puts [outputChannel] "Tests located in: [testsDirectory]" puts [outputChannel] "Tests running in: [workingDirectory]" puts [outputChannel] "Temporary files stored in\ [temporaryDirectory]" # [file system] first available in Tcl 8.4 if {![catch {file system [testsDirectory]} result] && ([lindex $result 0] ne "native")} { # If we aren't running in the native filesystem, then we must # run the tests in a single process (via 'source'), because # trying to run then via a pipe will fail since the files don't # really exist. singleProcess 1 } |
︙ | ︙ | |||
2780 2781 2782 2783 2784 2785 2786 | uplevel 1 [list ::source $file] } else { # Pass along our configuration to the child processes. # EXCEPT for the -outfile, because the parent process # needs to read and process output of children. set childargv [list] foreach opt [Configure] { | | | | 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 | uplevel 1 [list ::source $file] } else { # Pass along our configuration to the child processes. # EXCEPT for the -outfile, because the parent process # needs to read and process output of children. set childargv [list] foreach opt [Configure] { if {$opt eq "-outfile"} {continue} set value [Configure $opt] # Don't bother passing default configuration options if {$value eq $DefaultValue($opt)} { continue } lappend childargv $opt $value } set cmd [linsert $childargv 0 | $shell $file] if {[catch { incr numTestFiles |
︙ | ︙ | |||
2876 2877 2878 2879 2880 2881 2882 | # Results # none # # Side Effects: # none. proc tcltest::loadTestedCommands {} { | < < < < < | 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 | # Results # none # # Side Effects: # none. proc tcltest::loadTestedCommands {} { return [uplevel 1 [loadScript]] } # tcltest::saveState -- # # Save information regarding what procs and variables exist. # |
︙ | ︙ | |||
2923 2924 2925 2926 2927 2928 2929 | # # Side effects: # None. proc tcltest::restoreState {} { variable saveState foreach p [uplevel 1 {::info procs}] { | | < | | | 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 | # # Side effects: # None. proc tcltest::restoreState {} { variable saveState foreach p [uplevel 1 {::info procs}] { if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne [uplevel 1 [list ::namespace origin $p]])} { DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p" uplevel 1 [list ::catch [list ::rename $p {}]] } } foreach p [uplevel 1 {::info vars}] { if {$p ni [lindex $saveState 1]} { DebugPuts 2 "[lindex [info level 0] 0]:\ Removing variable $p" uplevel 1 [list ::catch [list ::unset $p]] } } return } |
︙ | ︙ | |||
2993 2994 2995 2996 2997 2998 2999 | set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]:\ putting ``$contents'' into $fullName" set fd [open $fullName w] | | | | | 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 | set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]:\ putting ``$contents'' into $fullName" set fd [open $fullName w] chan configure $fd -translation lf if {[string index $contents end] eq "\n"} { puts -nonewline $fd $contents } else { puts $fd $contents } close $fd if {$fullName ni $filesMade} { lappend filesMade $fullName } return $fullName } # tcltest::removeFile -- # |
︙ | ︙ | |||
3041 3042 3043 3044 3045 3046 3047 | } } if {![file isfile $fullName]} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not a file" } } | | | 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 | } } if {![file isfile $fullName]} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not a file" } } return [file delete -- $fullName] } # tcltest::makeDirectory -- # # Create a new dir with the name <name>. # # If this dir hasn't been created via makeDirectory since the last time |
︙ | ︙ | |||
3071 3072 3073 3074 3075 3076 3077 | FillFilesExisted if {[llength [info level 0]] == 2} { set directory [temporaryDirectory] } set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" file mkdir $fullName | | | 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 | FillFilesExisted if {[llength [info level 0]] == 2} { set directory [temporaryDirectory] } set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" file mkdir $fullName if {$fullName ni $filesMade} { lappend filesMade $fullName } return $fullName } # tcltest::removeDirectory -- # |
︙ | ︙ | |||
3112 3113 3114 3115 3116 3117 3118 | } } if {![file isdirectory $fullName]} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not a directory" } } | | | 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 | } } if {![file isdirectory $fullName]} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not a directory" } } return [file delete -force -- $fullName] } # tcltest::viewFile -- # # reads the content of a file and returns it # # Arguments: |
︙ | ︙ | |||
3209 3210 3211 3212 3213 3214 3215 | proc tcltest::LeakFiles {old} { if {[catch {testchannel open} new]} { return {} } set leak {} foreach p $new { | | | 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 | proc tcltest::LeakFiles {old} { if {[catch {testchannel open} new]} { return {} } set leak {} foreach p $new { if {$p ni $old} { lappend leak $p } } return $leak } # |
︙ | ︙ | |||
3280 3281 3282 3283 3284 3285 3286 | # Returns the number of existing threads. # # Side Effects: # none. # proc tcltest::threadReap {} { | | | | 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 | # Returns the number of existing threads. # # Side Effects: # none. # proc tcltest::threadReap {} { if {[info commands testthread] ne {}} { # testthread built into tcltest testthread errorproc ThreadNullError while {[llength [testthread names]] > 1} { foreach tid [testthread names] { if {$tid != [mainThread]} { catch { testthread send -async $tid {testthread exit} } } } ## Enter a bit a sleep to give the threads enough breathing ## room to kill themselves off, otherwise the end up with a ## massive queue of repeated events after 1 } testthread errorproc ThreadError return [llength [testthread names]] } elseif {[info commands thread::id] ne {}} { # Thread extension thread::errorproc ThreadNullError while {[llength [thread::names]] > 1} { foreach tid [thread::names] { if {$tid != [mainThread]} { |
︙ | ︙ | |||
3332 3333 3334 3335 3336 3337 3338 | namespace eval tcltest { # Define initializers for all the built-in contraint definitions DefineConstraintInitializers # Set up the constraints in the testConstraints array to be lazily # initialized by a registered initializer, or by "false" if no # initializer is registered. | | | | | 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 | namespace eval tcltest { # Define initializers for all the built-in contraint definitions DefineConstraintInitializers # Set up the constraints in the testConstraints array to be lazily # initialized by a registered initializer, or by "false" if no # initializer is registered. trace add variable testConstraints read [namespace code SafeFetch] # Only initialize constraints at package load time if an # [initConstraintsHook] has been pre-defined. This is only # for compatibility support. The modern way to add a custom # test constraint is to just call the [testConstraint] command # straight away, without all this "hook" nonsense. if {[namespace current] eq [namespace qualifiers [namespace which initConstraintsHook]]} { InitConstraints } else { proc initConstraintsHook {} {} } # Define the standard match commands customMatch exact [list string equal] |
︙ | ︙ | |||
3377 3378 3379 3380 3381 3382 3383 | } if {[info exists ::env(TCLTEST_OPTIONS)]} { ConfigureFromEnvironment } proc LoadTimeCmdLineArgParsingRequired {} { set required false | | | | | 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 | } if {[info exists ::env(TCLTEST_OPTIONS)]} { ConfigureFromEnvironment } proc LoadTimeCmdLineArgParsingRequired {} { set required false if {[info exists ::argv] && ("-help" in $::argv)} { # The command line asks for -help, so give it (and exit) # right now. ([configure] does not process -help) set required true } foreach hook { PrintUsageInfoHook processCmdLineArgsHook processCmdLineArgsAddFlagsHook } { if {[namespace current] eq [namespace qualifiers [namespace which $hook]]} { set required true } else { proc $hook args {} } } return $required } |
︙ | ︙ |
Changes to library/tm.tcl.
︙ | ︙ | |||
50 51 52 53 54 55 56 | # The regex pattern a file name has to match to make it a Tcl Module. set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$} # Export the public API namespace export path | | | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | # The regex pattern a file name has to match to make it a Tcl Module. set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$} # Export the public API namespace export path namespace ensemble create -command path -subcommands {add remove list} } # ::tcl::tm::path implementations -- # # Public API to the module path. See specification. # # Arguments |
︙ | ︙ | |||
256 257 258 259 260 261 262 | "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]" # We abort in this unknown handler only if we got a # satisfying candidate for the requested package. # Otherwise we still have to fallback to the regular # package search to complete the processing. | < | | < | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 | "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]" # We abort in this unknown handler only if we got a # satisfying candidate for the requested package. # Otherwise we still have to fallback to the regular # package search to complete the processing. if {($pkgname eq $name) && [package vsatisfies $pkgversion {*}$args]} { set satisfied 1 # We do not abort the loop, and keep adding provide # scripts for every candidate in the directory, just # remember to not fall back to the regular search # anymore. } |
︙ | ︙ | |||
355 356 357 358 359 360 361 | # Results # No result. # # Sideeffects # Calls 'path add' to paths to the list of module search paths. proc ::tcl::tm::roots {paths} { | | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 | # Results # No result. # # Sideeffects # Calls 'path add' to paths to the list of module search paths. proc ::tcl::tm::roots {paths} { regexp {^(\d+)\.(\d+)} [package present Tcl] - major minor foreach pa $paths { set p [file join $pa tcl$major] for {set n $minor} {$n >= 0} {incr n -1} { set px [file join $p ${major}.${n}] if {![interp issafe]} {set px [file normalize $px]} path add $px } |
︙ | ︙ |
Changes to library/word.tcl.
︙ | ︙ | |||
63 64 65 66 67 68 69 | # Arguments: # str - String to search. # start - Index into string specifying starting point. proc tcl_wordBreakAfter {str start} { variable ::tcl::WordBreakRE set result {-1 -1} | | | | | | | 63 64 65 66 67 68 69 70 71 72 73 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | # Arguments: # str - String to search. # start - Index into string specifying starting point. proc tcl_wordBreakAfter {str start} { variable ::tcl::WordBreakRE set result {-1 -1} regexp -indices -start $start -- $WordBreakRE(after) $str result return [lindex $result 1] } # tcl_wordBreakBefore -- # # This procedure returns the index of the first word boundary before the # starting point in the given string, or -1 if there are no more boundaries in # the given string. The index returned refers to the second character of the # pair that comprises a boundary. # # Arguments: # str - String to search. # start - Index into string specifying starting point. proc tcl_wordBreakBefore {str start} { variable ::tcl::WordBreakRE set result {-1 -1} regexp -indices -- $WordBreakRE(before) [string range $str 0 $start] result return [lindex $result 1] } # tcl_endOfWord -- # # This procedure returns the index of the first end-of-word location after a # starting index in the given string. An end-of-word location is defined to be # the first whitespace character following the first non-whitespace character # after the starting point. Returns -1 if there are no more words after the # starting point. # # Arguments: # str - String to search. # start - Index into string specifying starting point. proc tcl_endOfWord {str start} { variable ::tcl::WordBreakRE set result {-1 -1} regexp -indices -start $start -- $WordBreakRE(end) $str result return [lindex $result 1] } # tcl_startOfNextWord -- # # This procedure returns the index of the first start-of-word location after a # starting index in the given string. A start-of-word location is defined to # be a non-whitespace character following a whitespace character. Returns -1 # if there are no more start-of-word locations after the starting point. # # Arguments: # str - String to search. # start - Index into string specifying starting point. proc tcl_startOfNextWord {str start} { variable ::tcl::WordBreakRE set result {-1 -1} regexp -indices -start $start -- $WordBreakRE(next) $str result return [lindex $result 1] } # tcl_startOfPreviousWord -- # # This procedure returns the index of the first start-of-word location before # a starting index in the given string. # # Arguments: # str - String to search. # start - Index into string specifying starting point. proc tcl_startOfPreviousWord {str start} { variable ::tcl::WordBreakRE set word {-1 -1} regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \ result word return [lindex $word 0] } |
Changes to tests/assocd.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # This file tests the AssocData facility of Tcl # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # This file tests the AssocData facility of Tcl # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testgetassocdata [llength [info commands testgetassocdata]] testConstraint testsetassocdata [llength [info commands testsetassocdata]] testConstraint testdelassocdata [llength [info commands testdelassocdata]] |
︙ | ︙ | |||
56 57 58 59 60 61 62 | testdelassocdata 123 } "" test assocd-3.3 {testing deleting assoc data} testdelassocdata { list [catch {testdelassocdata nonexistent} msg] $msg } {0 {}} # cleanup | | | 54 55 56 57 58 59 60 61 62 | testdelassocdata 123 } "" test assocd-3.3 {testing deleting assoc data} testdelassocdata { list [catch {testdelassocdata nonexistent} msg] $msg } {0 {}} # cleanup cleanupTests return |
Changes to tests/basic.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 | | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testevalex [llength [info commands testevalex]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] testConstraint testcreatecommand [llength [info commands testcreatecommand]] testConstraint exec [llength [info commands exec]] catch {namespace delete test_ns_basic} catch {interp delete test_interp} catch {rename p ""} catch {rename q ""} catch {rename cmd ""} unset -nocomplain x test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { namespace eval test_ns_basic { proc p {} { |
︙ | ︙ | |||
298 299 300 301 302 303 304 | test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} { } {} test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} { } {} test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} unset -nocomplain x set x [namespace eval test_ns_basic::test_ns_basic2 { # the following creates a cmd in the global namespace testcmdtoken create p }] list [testcmdtoken name $x] \ [rename ::p q] \ [testcmdtoken name $x] |
︙ | ︙ | |||
351 352 353 354 355 356 357 | } {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2} test basic-23.1 {Tcl_DeleteCommand} {emptyTest} { } {} test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { catch {interp delete test_interp} | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 | } {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2} test basic-23.1 {Tcl_DeleteCommand} {emptyTest} { } {} test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { catch {interp delete test_interp} unset -nocomplain x interp create test_interp interp eval test_interp { proc useSet {} { return [set a 123] } } set x [interp eval test_interp {useSet}] |
︙ | ︙ | |||
423 424 425 426 427 428 429 | set fName [makeFile {} test1] } -body { # If object isn't preserved, errorInfo would be set to # "foo\n while executing\n\"garbage bytes\"" because the object's # string would have been freed, leaving garbage bytes for the error # message. set f [open $fName w] | | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 | set fName [makeFile {} test1] } -body { # If object isn't preserved, errorInfo would be set to # "foo\n while executing\n\"garbage bytes\"" because the object's # string would have been freed, leaving garbage bytes for the error # message. set f [open $fName w] chan event $f writable "chan event $f writable {}; error foo" set x {} vwait x close $f set x } -cleanup { removeFile test1 interp bgerror {} $handler |
︙ | ︙ | |||
543 544 545 546 547 548 549 | test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} { } {} test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} { catch {close $f} set res [catch { set f [open |[list [interpreter]] w+] | | | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 | test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} { } {} test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} { catch {close $f} set res [catch { set f [open |[list [interpreter]] w+] chan configure $f -buffering line puts $f {chan configure stdout -buffering line} puts $f continue puts $f {puts $::errorInfo} puts $f {puts DONE} set newMsg {} set msg {} while {$newMsg != "DONE"} { set newMsg [gets $f] |
︙ | ︙ | |||
968 969 970 971 972 973 974 | catch {namespace delete {*}[namespace children :: test_ns_*]} catch {namespace delete george} catch {interp delete test_interp} catch {rename p ""} catch {rename q ""} catch {rename cmd ""} catch {rename value:at: ""} | | | | 968 969 970 971 972 973 974 975 976 977 | catch {namespace delete {*}[namespace children :: test_ns_*]} catch {namespace delete george} catch {interp delete test_interp} catch {rename p ""} catch {rename q ""} catch {rename cmd ""} catch {rename value:at: ""} unset -nocomplain x cleanupTests return |
Changes to tests/cmdInfo.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | | < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testcmdinfo [llength [info commands testcmdinfo]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] |
︙ | ︙ | |||
97 98 99 100 101 102 103 | rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 lappend y {*}[testcmdtoken name $x] } {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2} # cleanup catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1} catch {rename x1 ""} | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 | rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 lappend y {*}[testcmdtoken name $x] } {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2} # cleanup catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1} catch {rename x1 ""} cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/dcall.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: none # # This file contains a collection of tests for Tcl_CallWhenDeleted. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # Commands covered: none # # This file contains a collection of tests for Tcl_CallWhenDeleted. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testdcall [llength [info commands testdcall]] test dcall-1.1 {deletion callbacks} testdcall { |
︙ | ︙ | |||
37 38 39 40 41 42 43 | lsort -increasing [testdcall 20 21 22 -21] } {20 22} test dcall-1.6 {deletion callbacks} testdcall { lsort -increasing [testdcall 20 21 22 -21 -22 -20] } {} # cleanup | | | 35 36 37 38 39 40 41 42 43 | lsort -increasing [testdcall 20 21 22 -21] } {20 22} test dcall-1.6 {deletion callbacks} testdcall { lsort -increasing [testdcall 20 21 22 -21 -22 -20] } {} # cleanup cleanupTests return |
Changes to tests/expr-old.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | | < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] |
︙ | ︙ | |||
135 136 137 138 139 140 141 | test expr-old-1.47 {integer operators} {expr 36%-5} -4 test expr-old-1.48 {integer operators} {expr -36/-5} 7 test expr-old-1.49 {integer operators} {expr -36%-5} -1 test expr-old-1.50 {integer operators} {expr +36} 36 test expr-old-1.51 {integer operators} {expr +--++36} 36 test expr-old-1.52 {integer operators} {expr +36%+5} 1 test expr-old-1.53 {integer operators} { | | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | test expr-old-1.47 {integer operators} {expr 36%-5} -4 test expr-old-1.48 {integer operators} {expr -36/-5} 7 test expr-old-1.49 {integer operators} {expr -36%-5} -1 test expr-old-1.50 {integer operators} {expr +36} 36 test expr-old-1.51 {integer operators} {expr +--++36} 36 test expr-old-1.52 {integer operators} {expr +36%+5} 1 test expr-old-1.53 {integer operators} { unset -nocomplain x set x yes list [expr {1 && $x}] [expr {$x && 1}] \ [expr {0 || $x}] [expr {$x || 0}] } {1 1 1 1} # Check the floating-point operators individually, along with # automatic conversion to integers where needed. |
︙ | ︙ | |||
443 444 445 446 447 448 449 | test expr-old-23.3 {double quotes} { set b2 xyx expr {"$b2$b2$b2.[set b2].[set b2]"} } xyxxyxxyx.xyx.xyx test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22 test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc} test expr-old-23.6 {double quotes} { | | | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 | test expr-old-23.3 {double quotes} { set b2 xyx expr {"$b2$b2$b2.[set b2].[set b2]"} } xyxxyxxyx.xyx.xyx test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22 test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc} test expr-old-23.6 {double quotes} { unset -nocomplain bogus__ list [catch {expr {"$bogus__"}} msg] $msg } {1 {can't read "bogus__": no such variable}} test expr-old-23.7 {double quotes} { list [catch {expr {"a[error Testing]bc"}} msg] $msg } {1 Testing} test expr-old-23.8 {double quotes} { list [catch {expr {"12398712938788234-1298379" != ""}} msg] $msg |
︙ | ︙ | |||
492 493 494 495 496 497 498 | } {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-26.2 {error conditions} -body { expr 2+4* } -returnCodes error -match glob -result * test expr-old-26.3 {error conditions} -body { expr 2+4*( } -returnCodes error -match glob -result * | | | 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 | } {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-26.2 {error conditions} -body { expr 2+4* } -returnCodes error -match glob -result * test expr-old-26.3 {error conditions} -body { expr 2+4*( } -returnCodes error -match glob -result * unset -nocomplain _non_existent_ test expr-old-26.4 {error conditions} { list [catch {expr 2+$_non_existent_} msg] $msg } {1 {can't read "_non_existent_": no such variable}} set a xx test expr-old-26.5 {error conditions} { list [catch {expr {2+$a}} msg] $msg } {1 {can't use non-numeric string "xx" as operand of "+"}} |
︙ | ︙ | |||
571 572 573 574 575 576 577 | set a } 1 test expr-old-27.4 {cancelled evaluation} { set a 1 expr {1?2:[set a 2]} set a } 1 | | | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 | set a } 1 test expr-old-27.4 {cancelled evaluation} { set a 1 expr {1?2:[set a 2]} set a } 1 unset -nocomplain x test expr-old-27.5 {cancelled evaluation} { list [catch {expr {[info exists x] && $x}} msg] $msg } {0 0} test expr-old-27.6 {cancelled evaluation} { list [catch {expr {0 && [concat $x]}} msg] $msg } {0 0} test expr-old-27.7 {cancelled evaluation} { |
︙ | ︙ |
Changes to tests/main.test.
︙ | ︙ | |||
125 126 127 128 129 130 131 | Tcl_Main: startup script - -encoding option } -constraints { stdio } -setup { set script [makeFile {} script] file delete $script set f [open $script w] | | | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 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 | Tcl_Main: startup script - -encoding option } -constraints { stdio } -setup { set script [makeFile {} script] file delete $script set f [open $script w] chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" close $f catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]} } -body { read $f } -cleanup { close $f removeFile script } -result [list script {} 0]\n1\n test Tcl_Main-1.8 { Tcl_Main: startup script - -encoding option - mismatched encodings } -constraints { stdio } -setup { set script [makeFile {} script] file delete $script set f [open $script w] chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" close $f catch {set f [open "|[list [interpreter] -encoding ascii script]" r]} } -body { read $f } -cleanup { close $f removeFile script } -result [list script {} 0]\n0\n test Tcl_Main-1.9 { Tcl_Main: startup script - -encoding option - no abbrevation } -constraints { stdio } -setup { set script [makeFile {} script] file delete $script set f [open $script w] chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" close $f catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]} } -body { type $f { |
︙ | ︙ | |||
588 589 590 591 592 593 594 | Tcl_Main able to handle non-blocking stdin } -constraints { exec } -setup { catch {set f [open "|[list [interpreter]]" w+]} } -body { type $f { | | | | | | | | | | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 | Tcl_Main able to handle non-blocking stdin } -constraints { exec } -setup { catch {set f [open "|[list [interpreter]]" w+]} } -body { type $f { chan configure stdin -blocking 0 puts SUCCESS } list [catch {gets $f} line] $line } -cleanup { close $f } -result [list 0 SUCCESS] test Tcl_Main-5.3 { Tcl_Main handles stdin EOF in mid-command } -constraints { exec } -setup { catch {set f [open "|[list [interpreter]]" w+]} catch {chan configure $f -blocking 0} } -body { type $f "chan configure stdin -eofchar \\032 if 1 \{\n\032" variable wait chan event $f readable \ [list set [namespace which -variable wait] "child exit"] set id [after 2000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait } -cleanup { if {$wait eq "timeout" && [testConstraint unix]} { exec kill [pid $f] } close $f } -result {child exit} test Tcl_Main-5.4 { Tcl_Main handles stdin EOF in mid-command } -constraints { exec } -setup { set cmd {makeFile "if 1 \{" script} catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]} catch {chan configure $f -blocking 0} } -body { variable wait chan event $f readable \ [list set [namespace which -variable wait] "child exit"] set id [after 2000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait } -cleanup { if {$wait eq "timeout" && [testConstraint unix]} { exec kill [pid $f] } close $f removeFile script } -result {child exit} test Tcl_Main-5.5 { |
︙ | ︙ | |||
744 745 746 747 748 749 750 | test Tcl_Main-5.10 { Tcl_Main: exit main loop in mid-interactive command } -constraints { exec Tcltest } -setup { catch {set f [open "|[list [interpreter]]" w+]} | | | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 | test Tcl_Main-5.10 { Tcl_Main: exit main loop in mid-interactive command } -constraints { exec Tcltest } -setup { catch {set f [open "|[list [interpreter]]" w+]} catch {chan configure $f -blocking 0} } -body { type $f "testsetmainloop after 2000 testexitmainloop puts \{1 2" after 4000 type $f "3 4\}" set code1 [catch {gets $f} line1] |
︙ | ︙ | |||
979 980 981 982 983 984 985 | test Tcl_Main-8.1 { StdinProc: handles non-blocking stdin } -constraints { exec Tcltest } -body { exec [interpreter] << { testsetmainloop | | | 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 | test Tcl_Main-8.1 { StdinProc: handles non-blocking stdin } -constraints { exec Tcltest } -body { exec [interpreter] << { testsetmainloop chan configure stdin -blocking 0 testexitmainloop } >& result set f [open result] read $f } -cleanup { close $f file delete result |
︙ | ︙ |
Changes to tests/msgcat.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. package require Tcl 8.5- if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } if {[catch {package require msgcat 1.5.0}]} { puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test." return |
︙ | ︙ | |||
52 53 54 55 56 57 58 | foreach setVars [PowerSet $envVars] { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } else { | | | | | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 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 | foreach setVars [PowerSet $envVars] { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } else { if {([info sharedlibextension] eq ".dll") && ![catch {package require registry}]} { # Windows and Cygwin have other ways to determine the # locale when the environment variables are missing # and the registry package is present continue } set result c } } test msgcat-0.$count [list \ locale initialization from environment variables $setVars \ ] -setup { variable var foreach var $envVars { catch {variable $var $::env($var)} unset -nocomplain ::env($var) } foreach var $setVars { set ::env($var) $var } interp create [namespace current]::i i eval [list package ifneeded msgcat [package provide msgcat] \ [package ifneeded msgcat [package provide msgcat]]] i eval package require msgcat } -cleanup { interp delete [namespace current]::i foreach var $envVars { unset -nocomplain ::env($var) catch {set ::env($var) [set [namespace current]::$var]} } } -body {i eval msgcat::mclocale} -result $result incr count } unset -nocomplain result # Could add tests of initialization from Windows registry here. # Use a fake registry package. # Tests msgcat-1.*: [mclocale], [mcpreferences] test msgcat-1.3 {mclocale set, single element} -setup { |
︙ | ︙ | |||
320 321 322 323 324 325 326 | mclocale $locale } -body { mc $string } -result $result($loc,$string) incr count } } | | | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 | mclocale $locale } -body { mc $string } -result $result($loc,$string) incr count } } unset -nocomplain result # Tests msgcat-4.*: [mcunknown] test msgcat-4.2 {mcunknown, default} -setup { mcset foo unk1 "unknown 1" variable locale [mclocale] mclocale foo |
︙ | ︙ |
Changes to tests/parse.test.
︙ | ︙ | |||
435 436 437 438 439 440 441 | interp delete $::slave catch {rename ::noSuchCommand {}} set ::info } global test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex { | | | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 | interp delete $::slave catch {rename ::noSuchCommand {}} set ::info } global test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex { unset -nocomplain x list [catch {testevalex {for {} 1 {} { # asdf set x }}}] $::errorInfo } {1 {can't read "x": no such variable |
︙ | ︙ | |||
476 477 478 479 480 481 482 | test parse-10.2 {Tcl_EvalTokens, backslash sequences} testevalex { testevalex {concat test\063\062test} } {test32test} test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex { testevalex {concat [expr 2 + 6]} } {8} test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex { | | | | | | | 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 | test parse-10.2 {Tcl_EvalTokens, backslash sequences} testevalex { testevalex {concat test\063\062test} } {test32test} test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex { testevalex {concat [expr 2 + 6]} } {8} test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex { unset -nocomplain a list [catch {testevalex {concat xxx[expr $a]}} msg] $msg } {1 {can't read "a": no such variable}} test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex { set a hello testevalex {concat $a} } {hello} test parse-10.6 {Tcl_EvalTokens, array variables} testevalex { unset -nocomplain a set a(12) 46 testevalex {concat $a(12)} } {46} test parse-10.7 {Tcl_EvalTokens, array variables} testevalex { unset -nocomplain a set a(12) 46 testevalex {concat $a(1[expr 3 - 1])} } {46} test parse-10.8 {Tcl_EvalTokens, array variables} testevalex { unset -nocomplain a list [catch {testevalex {concat $x($a)}} msg] $msg } {1 {can't read "a": no such variable}} test parse-10.9 {Tcl_EvalTokens, array variables} testevalex { unset -nocomplain a list [catch {testevalex {concat xyz$a(1)}} msg] $msg } {1 {can't read "a(1)": no such variable}} test parse-10.10 {Tcl_EvalTokens, object values} testevalex { set a 123 testevalex {concat $a} } {123} test parse-10.11 {Tcl_EvalTokens, object values} testevalex { |
︙ | ︙ | |||
538 539 540 541 542 543 544 | } -body { x } -result {321 777} test parse-11.2 {Tcl_EvalEx, error while parsing} testevalex { list [catch {testevalex {concat "abc}} msg] $msg } {1 {missing "}} test parse-11.3 {Tcl_EvalEx, error while collecting words} testevalex { | | | | | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 | } -body { x } -result {321 777} test parse-11.2 {Tcl_EvalEx, error while parsing} testevalex { list [catch {testevalex {concat "abc}} msg] $msg } {1 {missing "}} test parse-11.3 {Tcl_EvalEx, error while collecting words} testevalex { unset -nocomplain a list [catch {testevalex {concat xyz $a}} msg] $msg } {1 {can't read "a": no such variable}} test parse-11.4 {Tcl_EvalEx, error in Tcl_EvalObjv call} testevalex { unset -nocomplain a list [catch {testevalex {_bogus_ a b c d}} msg] $msg } {1 {invalid command name "_bogus_"}} test parse-11.5 {Tcl_EvalEx, exceptional return} testevalex { list [catch {testevalex {break}} msg] $msg } {3 {}} test parse-11.6 {Tcl_EvalEx, freeing memory} testevalex { testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z} } {a b c d e f g h i j k l m n o p q r s t u v w x y z} test parse-11.7 {Tcl_EvalEx, multiple commands in script} testevalex { list [testevalex {set a b; set c d}] $a $c } {d b d} test parse-11.8 {Tcl_EvalEx, multiple commands in script} testevalex { list [testevalex { set a b set c d }] $a $c } {d b d} test parse-11.9 {Tcl_EvalEx, freeing memory after error} testevalex { unset -nocomplain a list [catch {testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z $a}} msg] $msg } {1 {can't read "a": no such variable}} test parse-11.10 {Tcl_EvalTokens, empty commands} testevalex { testevalex {concat xyz; } } {xyz} test parse-11.11 {Tcl_EvalTokens, empty commands} testevalex { testevalex "concat abc; ; # this is a comment\n" |
︙ | ︙ | |||
667 668 669 670 671 672 673 | test parse-13.2 {Tcl_ParseVar procedure, no variable name} testparsevar { testparsevar {$} } {{$} {}} test parse-13.3 {Tcl_ParseVar procedure, no variable name} testparsevar { testparsevar {$.123} } {{$} .123} test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} testparsevar { | | | | 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 | test parse-13.2 {Tcl_ParseVar procedure, no variable name} testparsevar { testparsevar {$} } {{$} {}} test parse-13.3 {Tcl_ParseVar procedure, no variable name} testparsevar { testparsevar {$.123} } {{$} .123} test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} testparsevar { unset -nocomplain abc list [catch {testparsevar {$abc}} msg] $msg } {1 {can't read "abc": no such variable}} test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar { unset -nocomplain abc list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-14.2 {Tcl_ParseBraces procedure, computing string length} testparser { |
︙ | ︙ | |||
1088 1089 1090 1091 1092 1093 1094 | testparser {\x12X} 4 } {- {\x12} 1 word {\x12} 1 backslash {\x12} 0 X} test parse-20.12 {TclParseBackslash: truncated escape} testparser { testparser {\x12X} 5 } {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}} test parse-21.0 {Bug 1884496} testevent { | | | < | 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 | testparser {\x12X} 4 } {- {\x12} 1 word {\x12} 1 backslash {\x12} 0 X} test parse-20.12 {TclParseBackslash: truncated escape} testparser { testparser {\x12X} 5 } {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}} test parse-21.0 {Bug 1884496} testevent { set ::script {testevent delete a; set a [p]; set ::done $a} proc ::p {} {string first s $::script} testevent queue a head $::script vwait done } {} cleanupTests } namespace delete ::tcl::test::parse return |
Changes to tests/parseExpr.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the # file tclCompExpr.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # This file contains a collection of tests for the procedures in the # file tclCompExpr.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Note that the Tcl expression parser (tclCompExpr.c) does not check # the semantic validity of the expressions it parses. It does not check, # for example, that a math function actually exists, or that the operands |
︙ | ︙ | |||
1062 1063 1064 1065 1066 1067 1068 | test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body { catch {testexprparser 0b02 -1} m o dict get $o -errorcode } -result {TCL PARSE EXPR BADNUMBER BINARY} # cleanup | | | 1060 1061 1062 1063 1064 1065 1066 1067 1068 | test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body { catch {testexprparser 0b02 -1} m o dict get $o -errorcode } -result {TCL PARSE EXPR BADNUMBER BINARY} # cleanup cleanupTests return |
Changes to tests/parseOld.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | | < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testwordend [llength [info commands testwordend]] # Save the argv value for restoration later |
︙ | ︙ | |||
162 163 164 165 166 167 168 | } a78b test parseOld-5.5 {variable substitution} {catch {$_non_existent_} msg} 1 test parseOld-5.6 {variable substitution} { catch {$_non_existent_} msg set msg } {can't read "_non_existent_": no such variable} test parseOld-5.7 {array variable substitution} { | | | | | | | | | | 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 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 | } a78b test parseOld-5.5 {variable substitution} {catch {$_non_existent_} msg} 1 test parseOld-5.6 {variable substitution} { catch {$_non_existent_} msg set msg } {can't read "_non_existent_": no such variable} test parseOld-5.7 {array variable substitution} { unset -nocomplain a set a(xyz) 123 set b $a(xyz)foo set b } 123foo test parseOld-5.8 {array variable substitution} { unset -nocomplain a set "a(x y z)" 123 set b $a(x y z)foo set b } 123foo test parseOld-5.9 {array variable substitution} { unset -nocomplain a qqq set "a(x y z)" qqq set $a([format x]\ y [format z]) foo set qqq } foo test parseOld-5.10 {array variable substitution} { unset -nocomplain a list [catch {set b $a(22)} msg] $msg } {1 {can't read "a(22)": no such variable}} test parseOld-5.11 {array variable substitution} { set b a$! set b } {a$!} test parseOld-5.12 {empty array name support} { list [catch {set b a$()} msg] $msg } {1 {can't read "()": no such variable}} unset -nocomplain a test parseOld-5.13 {array variable substitution} { unset -nocomplain a set long {This is a very long variable, long enough to cause storage \ allocation to occur in Tcl_ParseVar. If that storage isn't getting \ freed up correctly, then a core leak will occur when this test is \ run. This text is probably beginning to sound like drivel, but I've \ run out of things to say and I need more characters still.} set a($long) 777 set b $a($long) list $b [array names a] } {777 {{This is a very long variable, long enough to cause storage \ allocation to occur in Tcl_ParseVar. If that storage isn't getting \ freed up correctly, then a core leak will occur when this test is \ run. This text is probably beginning to sound like drivel, but I've \ run out of things to say and I need more characters still.}}} test parseOld-5.14 {array variable substitution} { unset -nocomplain a b a1 set a1(22) foo set a(foo) bar set b $a($a1(22)) set b } bar unset -nocomplain a a1 test parseOld-7.1 {backslash substitution} { set a "\a\c\n\]\}" string length $a } 5 test parseOld-7.2 {backslash substitution} { set a {\a\c\n\]\}} |
︙ | ︙ |
Changes to tests/pkgMkIndex.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains tests for the pkg_mkIndex command. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. | < | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # This file contains tests for the pkg_mkIndex command. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2 namespace import ::tcltest::* set fullPkgPath [makeDirectory pkg] namespace eval pkgtest { # Namespace for procs we can discard } |
︙ | ︙ | |||
41 42 43 44 45 46 47 | set options "" set argc [llength $args] for {set iarg 0} {$iarg < $argc} {incr iarg} { set a [lindex $args $iarg] if {[regexp {^-} $a]} { lappend options $a | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | set options "" set argc [llength $args] for {set iarg 0} {$iarg < $argc} {incr iarg} { set a [lindex $args $iarg] if {[regexp {^-} $a]} { lappend options $a if {$a eq "-load"} { incr iarg lappend options [lindex $args $iarg] } } else { break } } |
︙ | ︙ | |||
77 78 79 80 81 82 83 | # create a slave interpreter, where we override "package ifneeded" set slave [interp create] if {[catch { $slave eval { rename package package_original proc package { args } { | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | # create a slave interpreter, where we override "package ifneeded" set slave [interp create] if {[catch { $slave eval { rename package package_original proc package { args } { if {[lindex $args 0] eq "ifneeded"} { set pkg [lindex $args 1] set ver [lindex $args 2] set ::PKGS($pkg:$ver) [lindex $args 3] } else { return [package_original {*}$args] } } |
︙ | ︙ | |||
107 108 109 110 111 112 113 | set P($k) $v } set PKGS "" foreach k [lsort [array names P]] { lappend PKGS $k $P($k) } | | | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | set P($k) $v } set PKGS "" foreach k [lsort [array names P]] { lappend PKGS $k $P($k) } } err opts]} { set ei [dict get $opts -errorinfo] set ec [dict get $opts -errorcode] catch {interp delete $slave} error $ei $ec } interp delete $slave |
︙ | ︙ |
Changes to tests/platform.test.
1 2 3 4 5 6 7 8 9 10 11 | # The file tests the tcl_platform variable # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1999 by Scriptics Corporation # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | > > > | > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # The file tests the tcl_platform variable # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1999 by Scriptics Corporation # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace eval ::tcl::test::platform { namespace import ::tcltest::testConstraint namespace import ::tcltest::test namespace import ::tcltest::cleanupTests variable ::tcl_platform ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testCPUID [llength [info commands testcpuid]] test platform-1.1 {TclpSetVariables: tcl_platform} { |
︙ | ︙ | |||
50 51 52 53 54 55 56 | [lindex $cpudata 3] \ [lindex $cpudata 2] } \ -match regexp \ -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$} # cleanup | | > > > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | [lindex $cpudata 3] \ [lindex $cpudata 2] } \ -match regexp \ -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$} # cleanup cleanupTests } namespace delete ::tcl::test::platform return # Local Variables: # mode: tcl # End: |
Changes to tests/result.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the routines in tclResult.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # This file tests the routines in tclResult.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testsaveresult command testConstraint testsaveresult [llength [info commands testsaveresult]] |
︙ | ︙ |
Changes to tests/stack.test.
1 2 3 4 5 6 7 8 9 10 11 | # Tests that the stack size is big enough for the application. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # Tests that the stack size is big enough for the application. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import ::tcltest::* # Note that a failure in this test may result in a crash of the executable. test stack-1.1 {maxNestingDepth reached on infinite recursion} -body { # do this in a sub process in case it segfaults exec [interpreter] << { proc recurse {} { recurse } |
︙ | ︙ |
Changes to tests/tcltest.test.
︙ | ︙ | |||
76 77 78 79 80 81 82 | i eval [list set argv [lrange $args 1 end]] i eval [list package ifneeded tcltest [package provide tcltest] \ [package ifneeded tcltest [package provide tcltest]]] i eval {proc exit args {}} # Need to capture output in msg | | < < < < < | 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 102 103 104 105 | i eval [list set argv [lrange $args 1 end]] i eval [list package ifneeded tcltest [package provide tcltest] \ [package ifneeded tcltest [package provide tcltest]]] i eval {proc exit args {}} # Need to capture output in msg set code [catch {i eval {source $argv0}}] i eval {close $tcltest::outputChannel} interp delete [namespace current]::i set f [open $of] set msg [read -nonewline $f] close $f set f [open $ef] set err [read -nonewline $f] close $f removeFile output removeFile error if {[string length $err]} { set code 1 append msg \n$err } return $code } test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} { set result [slave msg test.tcl] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} |
︙ | ︙ | |||
545 546 547 548 549 550 551 | } # Test non-writeable directories, non-readable directories with directory flags set notReadableDir [file join [temporaryDirectory] notreadable] set notWriteableDir [file join [temporaryDirectory] notwriteable] makeDirectory notreadable makeDirectory notwriteable switch -- $::tcl_platform(platform) { | | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 | } # Test non-writeable directories, non-readable directories with directory flags set notReadableDir [file join [temporaryDirectory] notreadable] set notWriteableDir [file join [temporaryDirectory] notwriteable] makeDirectory notreadable makeDirectory notwriteable switch -- $::tcl_platform(platform) { unix { file attributes $notReadableDir -permissions 00333 file attributes $notWriteableDir -permissions 00555 } default { catch {file attributes $notWriteableDir -readonly 1} catch {testchmod 000 $notWriteableDir} } |
︙ | ︙ | |||
712 713 714 715 716 717 718 | set ::tcltest::workingDirectory $old cd $current } } # clean up from directory testing | | | | | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 | set ::tcltest::workingDirectory $old cd $current } } # clean up from directory testing switch -- $::tcl_platform(platform) { unix { file attributes $notReadableDir -permissions 777 file attributes $notWriteableDir -permissions 777 } default { catch {testchmod 777 $notWriteableDir} catch {file attributes $notWriteableDir -readonly 0} } } file delete -force -- $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup { set old [testsDirectory] |
︙ | ︙ | |||
1146 1147 1148 1149 1150 1151 1152 | slave1 eval [list set argv {-debug 2}] slave1 alias puts puts interp create slave2 slave2 alias puts puts } -cleanup { interp delete slave2 interp delete slave1 | | | 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 | slave1 eval [list set argv {-debug 2}] slave1 alias puts puts interp create slave2 slave2 alias puts puts } -cleanup { interp delete slave2 interp delete slave1 if {$oldoptions eq "none"} { unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } } -body { slave1 eval [package ifneeded tcltest [package provide tcltest]] slave1 eval tcltest::debug |
︙ | ︙ |
Changes to tests/thread.test.
︙ | ︙ | |||
80 81 82 83 84 85 86 | proc drainEventQueue {} { while {[set x [testthread event]]} { #puts "WARNING: drained $x event(s) on main thread" } } testthread errorproc ThreadError | < < < < < < < < < < < < < < < < < < < < < < | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | proc drainEventQueue {} { while {[set x [testthread event]]} { #puts "WARNING: drained $x event(s) on main thread" } } testthread errorproc ThreadError } # Some tests require manual draining of the event queue testConstraint drainEventQueue [expr {[info commands drainEventQueue] != {}}] test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} { |
︙ | ︙ |
Changes to tests/tm.test.
︙ | ︙ | |||
196 197 198 199 200 201 202 | ::tcl::tm::path list } -result {geode snarf foo} proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] | | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 | ::tcl::tm::path list } -result {geode snarf foo} proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] lassign [split [package present Tcl] .] major minor set results {} set base8 [file join $base tcl8] lappend results [file join $base8 site-tcl] for {set i 0} {$i <= 7} {incr i} { lappend results [file join $base8 8.$i] } set base [file join $base tcl$major] |
︙ | ︙ |
Changes to tests/trace.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: trace # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | | < | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | # Commands covered: trace # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevalobjv [llength [info commands testevalobjv]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] proc getbytes {} { set lines [split [memory info] "\n"] lindex [lindex $lines 3] 3 } proc traceScalar {name1 name2 op} { global info set info [list $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg] } proc traceScalarAppend {name1 name2 op} { global info lappend info $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg } proc traceArray {name1 name2 op} { global info set info [list $name1 $name2 $op [catch {uplevel 1 set [set name1]($name2)} msg] $msg] } proc traceArray2 {name1 name2 op} { global info set info [list $name1 $name2 $op] } proc traceProc {name1 name2 op} { global info |
︙ | ︙ | |||
58 59 60 61 62 63 64 | error "trace returned error" } proc traceCheck {cmd args} { global info set info [list [catch $cmd msg] $msg] } proc traceCrtElement {value name1 name2 op} { | | | | | | | | | | | | | | | | | | | | | | | | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 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 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 | error "trace returned error" } proc traceCheck {cmd args} { global info set info [list [catch $cmd msg] $msg] } proc traceCrtElement {value name1 name2 op} { uplevel 1 set ${name1}($name2) $value } proc traceCommand {oldName newName op} { global info set info [list $oldName $newName $op] } test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { # You may need Purify or Electric Fence to reliably # see this one fail. unset -nocomplain z trace add variable z array {set z(foo) 1 ;#} set res "names: [array names z]" unset -nocomplain ::z trace variable ::z w {unset ::z; error "memory corruption";#} list [catch {set ::z 1} msg] $msg } {1 {can't set "::z": memory corruption}} # Read-tracing on variables test trace-1.1 {trace variable reads} { unset -nocomplain x set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}} test trace-1.2 {trace variable reads} { unset -nocomplain x set x 123 set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {0 123 {x {} read 0 123}} test trace-1.3 {trace variable reads} { unset -nocomplain x set info {} trace add variable x read traceScalar set x 123 set info } {} test trace-1.4 {trace array element reads} { unset -nocomplain x set info {} trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}} test trace-1.5 {trace array element reads} { unset -nocomplain x set x(2) zzz set info {} trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} test trace-1.6 {trace array element reads} { unset -nocomplain x set info {} trace add variable x read traceArray2 proc p {} { global x set x(2) willi return $x(2) } list [catch {p} msg] $msg $info } {0 willi {x 2 read}} test trace-1.7 {trace array element reads, create element undefined if nonexistant} { unset -nocomplain x set info {} trace add variable x read q proc q {name1 name2 op} { global info set info [list $name1 $name2 $op] global $name1 set ${name1}($name2) wolf } proc p {} { global x set x(X) willi return $x(Y) } list [catch {p} msg] $msg $info } {0 wolf {x Y read}} test trace-1.8 {trace reads on whole arrays} { unset -nocomplain x set info {} trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such variable} {}} test trace-1.9 {trace reads on whole arrays} { unset -nocomplain x set x(2) zzz set info {} trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} test trace-1.10 {trace variable reads} { unset -nocomplain x set x 444 set info {} trace add variable x read traceScalar unset x set info } {} test trace-1.11 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 trace variable x r {set x(foo) 1 ;#} trace variable x r {unset -nocomplain x(bar) ;#} array get x } {} test trace-1.12 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 trace variable x r {unset -nocomplain x(bar) ;#} trace variable x r {set x(foo) 1 ;#} array get x } {} test trace-1.13 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 trace variable x r {set x(foo) 1 ;#} trace variable x r {unset -nocomplain x;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} test trace-1.14 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 trace variable x r {unset -nocomplain x;#} trace variable x r {set x(foo) 1 ;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} # Basic write-tracing on variables test trace-2.1 {trace variable writes} { unset -nocomplain x set info {} trace add variable x write traceScalar set x 123 set info } {x {} write 0 123} test trace-2.2 {trace writes to array elements} { unset -nocomplain x set info {} trace add variable x(33) write traceArray set x(33) 444 set info } {x 33 write 0 444} test trace-2.3 {trace writes on whole arrays} { unset -nocomplain x set info {} trace add variable x write traceArray set x(abc) qq set info } {x abc write 0 qq} test trace-2.4 {trace variable writes} { unset -nocomplain x set x 1234 set info {} trace add variable x write traceScalar set x set info } {} test trace-2.5 {trace variable writes} { unset -nocomplain x set x 1234 set info {} trace add variable x write traceScalar unset x set info } {} test trace-2.6 {trace variable writes on compiled local} { # # Check correct function of whole array traces on compiled local # arrays [Bug 1770591]. The corresponding function for read traces is # already indirectly tested in trace-1.7 # unset -nocomplain x set info {} proc p {} { trace add variable x write traceArray set x(X) willy } p set info |
︙ | ︙ | |||
263 264 265 266 267 268 269 | # append no longer triggers read traces when fetching the old values of # variables before doing the append operation. However, lappend _does_ # still trigger these read traces. Also lappend triggers only one write # trace: after appending all arguments to the list. test trace-3.1 {trace variable read-modify-writes} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 261 262 263 264 265 266 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 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 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 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 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 770 | # append no longer triggers read traces when fetching the old values of # variables before doing the append operation. However, lappend _does_ # still trigger these read traces. Also lappend triggers only one write # trace: after appending all arguments to the list. test trace-3.1 {trace variable read-modify-writes} { unset -nocomplain x set info {} trace add variable x read traceScalarAppend append x 123 append x 456 lappend x 789 set info } {x {} read 0 123456} test trace-3.2 {trace variable read-modify-writes} { unset -nocomplain x set info {} trace add variable x {read write} traceScalarAppend append x 123 lappend x 456 set info } {x {} write 0 123 x {} read 0 123 x {} write 0 {123 456}} # Basic unset-tracing on variables test trace-4.1 {trace variable unsets} { unset -nocomplain x set info {} trace add variable x unset traceScalar unset -nocomplain x set info } {x {} unset 1 {can't read "x": no such variable}} test trace-4.2 {variable mustn't exist during unset trace} { unset -nocomplain x set x 1234 set info {} trace add variable x unset traceScalar unset x set info } {x {} unset 1 {can't read "x": no such variable}} test trace-4.3 {unset traces mustn't be called during reads and writes} { unset -nocomplain x set info {} trace add variable x unset traceScalar set x 44 set x set info } {} test trace-4.4 {trace unsets on array elements} { unset -nocomplain x set x(0) 18 set info {} trace add variable x(1) unset traceArray unset -nocomplain x(1) set info } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.5 {trace unsets on array elements} { unset -nocomplain x set x(1) 18 set info {} trace add variable x(1) unset traceArray unset x(1) set info } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.6 {trace unsets on array elements} { unset -nocomplain x set x(1) 18 set info {} trace add variable x(1) unset traceArray unset x set info } {x 1 unset 1 {can't read "x(1)": no such variable}} test trace-4.7 {trace unsets on whole arrays} { unset -nocomplain x set x(1) 18 set info {} trace add variable x unset traceProc unset -nocomplain x(0) set info } {} test trace-4.8 {trace unsets on whole arrays} { unset -nocomplain x set x(1) 18 set x(2) 144 set x(3) 14 set info {} trace add variable x unset traceProc unset x(1) set info } {x 1 unset} test trace-4.9 {trace unsets on whole arrays} { unset -nocomplain x set x(1) 18 set x(2) 144 set x(3) 14 set info {} trace add variable x unset traceProc unset x set info } {x {} unset} # Array tracing on variables test trace-5.1 {array traces fire on accesses via [array]} { unset -nocomplain x set x(b) 2 trace add variable x array traceArray2 set ::info {} array set x {a 1} set ::info } {x {} array} test trace-5.2 {array traces do not fire on normal accesses} { unset -nocomplain x set x(b) 2 trace add variable x array traceArray2 set ::info {} set x(a) 1 set x(b) $x(a) set ::info } {} test trace-5.3 {array traces do not outlive variable} { unset -nocomplain x trace add variable x array traceArray2 set ::info {} set x(a) 1 unset x array set x {a 1} set ::info } {} test trace-5.4 {array traces properly listed in trace information} { unset -nocomplain x trace add variable x array traceArray2 set result [trace info variable x] set result } [list [list array traceArray2]] test trace-5.5 {array traces properly listed in trace information} { unset -nocomplain x trace variable x a traceArray2 set result [trace vinfo x] set result } [list [list a traceArray2]] test trace-5.6 {array traces don't fire on scalar variables} { unset -nocomplain x set x foo trace add variable x array traceArray2 set ::info {} catch {array set x {a 1}} set ::info } {} test trace-5.7 {array traces fire for undefined variables} { unset -nocomplain x trace add variable x array traceArray2 set ::info {} array set x {a 1} set ::info } {x {} array} test trace-5.8 {array traces fire for undefined variables} { unset -nocomplain x trace add variable x array {set x(foo) 1 ;#} set res "names: [array names x]" } {names: foo} # Trace multiple trace types at once. test trace-6.1 {multiple ops traced at once} { unset -nocomplain x set info {} trace add variable x {read write unset} traceProc catch {set x} set x 22 set x set x 33 unset x set info } {x {} read x {} write x {} read x {} write x {} unset} test trace-6.2 {multiple ops traced on array element} { unset -nocomplain x set info {} trace add variable x(0) {read write unset} traceProc catch {set x(0)} set x(0) 22 set x(0) set x(0) 33 unset x(0) unset x set info } {x 0 read x 0 write x 0 read x 0 write x 0 unset} test trace-6.3 {multiple ops traced on whole array} { unset -nocomplain x set info {} trace add variable x {read write unset} traceProc catch {set x(0)} set x(0) 22 set x(0) set x(0) 33 unset x(0) unset x set info } {x 0 write x 0 read x 0 write x 0 unset x {} unset} # Check order of invocation of traces test trace-7.1 {order of invocation of traces} { unset -nocomplain x set info {} trace add variable x read "traceTag 1" trace add variable x read "traceTag 2" trace add variable x read "traceTag 3" catch {set x} set x 22 set x set info } {3 2 1 3 2 1} test trace-7.2 {order of invocation of traces} { unset -nocomplain x set x(0) 44 set info {} trace add variable x(0) read "traceTag 1" trace add variable x(0) read "traceTag 2" trace add variable x(0) read "traceTag 3" set x(0) set info } {3 2 1} test trace-7.3 {order of invocation of traces} { unset -nocomplain x set x(0) 44 set info {} trace add variable x(0) read "traceTag 1" trace add variable x read "traceTag A1" trace add variable x(0) read "traceTag 2" trace add variable x read "traceTag A2" trace add variable x(0) read "traceTag 3" trace add variable x read "traceTag A3" set x(0) set info } {A3 A2 A1 3 2 1} # Check effects of errors in trace procedures test trace-8.1 {error returns from traces} { unset -nocomplain x set x 123 set info {} trace add variable x read "traceTag 1" trace add variable x read traceError list [catch {set x} msg] $msg $info } {1 {can't read "x": trace returned error} {}} test trace-8.2 {error returns from traces} { unset -nocomplain x set x 123 set info {} trace add variable x write "traceTag 1" trace add variable x write traceError list [catch {set x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-8.3 {error returns from traces} { unset -nocomplain x set x 123 set info {} trace add variable x write traceError list [catch {append x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-8.4 {error returns from traces} { unset -nocomplain x set x 123 set info {} trace add variable x unset "traceTag 1" trace add variable x unset traceError list [catch {unset x} msg] $msg $info } {0 {} 1} test trace-8.5 {error returns from traces} { unset -nocomplain x set x(0) 123 set info {} trace add variable x(0) read "traceTag 1" trace add variable x read "traceTag 2" trace add variable x read traceError trace add variable x read "traceTag 3" list [catch {set x(0)} msg] $msg $info } {1 {can't read "x(0)": trace returned error} 3} test trace-8.6 {error returns from traces} { unset -nocomplain x set x 123 trace add variable x unset traceError list [catch {unset x} msg] $msg } {0 {}} test trace-8.7 {error returns from traces} { # This test just makes sure that the memory for the error message # gets deallocated correctly when the trace is invoked again or # when the trace is deleted. unset -nocomplain x set x 123 trace add variable x read traceError catch {set x} catch {set x} trace remove variable x read traceError } {} test trace-8.8 {error returns from traces} { # Yet more elaborate memory corruption testing that checks nothing # bad happens when the trace deletes itself and installs something # new. Alas, there is no neat way to guarantee that this test will # fail if there is a problem, but that's life and with the new code # it should *never* fail. # # Adapted from Bug #219393 reported by Don Porter. catch {rename ::foo {}} proc foo {old args} { trace remove variable ::x write [list foo $old] trace add variable ::x write [list foo $::x] error "foo" } unset -nocomplain ::x ::y set x junk trace add variable ::x write [list foo $x] for {set y 0} {$y<100} {incr y} { catch {set x junk} } unset x } {} # Check to see that variables are expunged before trace # procedures are invoked, so trace procedure can even manipulate # a new copy of the variables. test trace-9.1 {be sure variable is unset before trace is called} { unset -nocomplain x set x 33 set info {} trace add variable x unset {traceCheck {uplevel 1 set x}} unset x set info } {1 {can't read "x": no such variable}} test trace-9.2 {be sure variable is unset before trace is called} { unset -nocomplain x set x 33 set info {} trace add variable x unset {traceCheck {uplevel 1 set x 22}} unset x concat $info [list [catch {set x} msg] $msg] } {0 22 0 22} test trace-9.3 {be sure traces are cleared before unset trace called} { unset -nocomplain x set x 33 set info {} trace add variable x unset {traceCheck {uplevel 1 trace info variable x}} unset x set info } {0 {}} test trace-9.4 {set new trace during unset trace} { unset -nocomplain x set x 33 set info {} trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}} unset x concat $info [trace info variable x] } {0 {} {unset traceProc}} test trace-10.1 {make sure array elements are unset before traces are called} { unset -nocomplain x set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {uplevel 1 set x(0)}} unset x(0) set info } {1 {can't read "x(0)": no such element in array}} test trace-10.2 {make sure array elements are unset before traces are called} { unset -nocomplain x set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {uplevel 1 set x(0) zzz}} unset x(0) concat $info [list [catch {set x(0)} msg] $msg] } {0 zzz 0 zzz} test trace-10.3 {array elements are unset before traces are called} { unset -nocomplain x set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}} unset x(0) set info } {0 {}} test trace-10.4 {set new array element trace during unset trace} { unset -nocomplain x set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {uplevel 1 {trace add variable x(0) read {}}}} unset -nocomplain x(0) concat $info [trace info variable x(0)] } {0 {} {read {}}} test trace-11.1 {make sure arrays are unset before traces are called} { unset -nocomplain x set x(0) 33 set info {} trace add variable x unset {traceCheck {uplevel 1 set x(0)}} unset x set info } {1 {can't read "x(0)": no such variable}} test trace-11.2 {make sure arrays are unset before traces are called} { unset -nocomplain x set x(y) 33 set info {} trace add variable x unset {traceCheck {uplevel 1 set x(y) 22}} unset x concat $info [list [catch {set x(y)} msg] $msg] } {0 22 0 22} test trace-11.3 {make sure arrays are unset before traces are called} { unset -nocomplain x set x(y) 33 set info {} trace add variable x unset {traceCheck {uplevel 1 array exists x}} unset x set info } {0 0} test trace-11.4 {make sure arrays are unset before traces are called} { unset -nocomplain x set x(y) 33 set info {} set cmd {traceCheck {uplevel 1 {trace info variable x}}} trace add variable x unset $cmd unset x set info } {0 {}} test trace-11.5 {set new array trace during unset trace} { unset -nocomplain x set x(y) 33 set info {} trace add variable x unset {traceCheck {global x; trace add variable x read {}}} unset x concat $info [trace info variable x] } {0 {} {read {}}} test trace-11.6 {create scalar during array unset trace} { unset -nocomplain x set x(y) 33 set info {} trace add variable x unset {traceCheck {global x; set x 44}} unset x concat $info [list [catch {set x} msg] $msg] } {0 44 0 44} # Check special conditions (e.g. errors) in Tcl_TraceVar2. test trace-12.1 {creating array when setting variable traces} { unset -nocomplain x set info {} trace add variable x(0) write traceProc list [catch {set x 22} msg] $msg } {1 {can't set "x": variable is array}} test trace-12.2 {creating array when setting variable traces} { unset -nocomplain x set info {} trace add variable x(0) write traceProc list [catch {set x(0)} msg] $msg } {1 {can't read "x(0)": no such element in array}} test trace-12.3 {creating array when setting variable traces} { unset -nocomplain x set info {} trace add variable x(0) write traceProc set x(0) 22 set info } {x 0 write} test trace-12.4 {creating variable when setting variable traces} { unset -nocomplain x set info {} trace add variable x write traceProc list [catch {set x} msg] $msg } {1 {can't read "x": no such variable}} test trace-12.5 {creating variable when setting variable traces} { unset -nocomplain x set info {} trace add variable x write traceProc set x 22 set info } {x {} write} test trace-12.6 {creating variable when setting variable traces} { unset -nocomplain x set info {} trace add variable x write traceProc set x(0) 22 set info } {x 0 write} test trace-12.7 {create array element during read trace} { unset -nocomplain x set x(2) zzz trace add variable x read {traceCrtElement xyzzy} list [catch {set x(3)} msg] $msg } {0 xyzzy} test trace-12.8 {errors when setting variable traces} { unset -nocomplain x set x 44 list [catch {trace add variable x(0) write traceProc} msg] $msg } {1 {can't trace "x(0)": variable isn't array}} # Check trace deletion test trace-13.1 {delete one trace from another} { proc delTraces {args} { global x trace remove variable x read {traceTag 2} trace remove variable x read {traceTag 3} trace remove variable x read {traceTag 4} } unset -nocomplain x set x 44 set info {} trace add variable x read {traceTag 1} trace add variable x read {traceTag 2} trace add variable x read {traceTag 3} trace add variable x read {traceTag 4} trace add variable x read delTraces |
︙ | ︙ | |||
912 913 914 915 916 917 918 | } [list 1 "wrong # args: should be \"trace variable name ops command\""] test trace-14.11 {trace command, "trace variable" errors} { list [catch {trace variable x y z} msg] $msg } [list 1 "bad operations \"y\": should be one or more of rwua"] test trace-14.12 {trace command ("remove variable" option)} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 | } [list 1 "wrong # args: should be \"trace variable name ops command\""] test trace-14.11 {trace command, "trace variable" errors} { list [catch {trace variable x y z} msg] $msg } [list 1 "bad operations \"y\": should be one or more of rwua"] test trace-14.12 {trace command ("remove variable" option)} { unset -nocomplain x set info {} trace add variable x write traceProc trace remove variable x write traceProc } {} test trace-14.13 {trace command ("remove variable" option)} { unset -nocomplain x set info {} trace add variable x write traceProc trace remove variable x write traceProc set x 12345 set info } {} test trace-14.14 {trace command ("remove variable" option)} { unset -nocomplain x set info {} trace add variable x write {traceTag 1} trace add variable x write traceProc trace add variable x write {traceTag 2} set x yy trace remove variable x write traceProc set x 12345 trace remove variable x write {traceTag 1} set x foo trace remove variable x write {traceTag 2} set x gorp set info } {2 x {} write 1 2 1 2} test trace-14.15 {trace command ("remove variable" option)} { unset -nocomplain x set info {} trace add variable x write {traceTag 1} trace remove variable x write non_existent set x 12345 set info } {1} test trace-14.16 {trace command ("info variable" option)} { unset -nocomplain x trace add variable x write {traceTag 1} trace add variable x write traceProc trace add variable x write {traceTag 2} trace info variable x } {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}} test trace-14.17 {trace command ("info variable" option)} { unset -nocomplain x trace info variable x } {} test trace-14.18 {trace command ("info variable" option)} { unset -nocomplain x trace info variable x(0) } {} test trace-14.19 {trace command ("info variable" option)} { unset -nocomplain x set x 44 trace info variable x(0) } {} test trace-14.20 {trace command ("info variable" option)} { unset -nocomplain x set x 44 trace add variable x write {traceTag 1} proc check {} {global x; trace info variable x} check } {{write {traceTag 1}}} # Check fancy trace commands (long ones, weird arguments, etc.) test trace-15.1 {long trace command} { unset -nocomplain x set info {} trace add variable x write {traceTag {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ with such long arguments by malloc-ing space. One possibility \ is that space doesn't get freed properly. If this happens, then \ invoking this test over and over again will eventually leak memory.}} set x 44 set info } {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ with such long arguments by malloc-ing space. One possibility \ is that space doesn't get freed properly. If this happens, then \ invoking this test over and over again will eventually leak memory.} test trace-15.2 {long trace command result to ignore} { proc longResult {args} {return "quite a bit of text, designed to generate a core leak if this command file is invoked over and over again and memory isn't being recycled correctly"} unset -nocomplain x trace add variable x write longResult set x 44 set x 5 set x abcde } abcde test trace-15.3 {special list-handling in trace commands} { unset -nocomplain "x y z" set "x y z(a\n\{)" 44 set info {} trace add variable "x y z(a\n\{)" write traceProc set "x y z(a\n\{)" 33 set info } "{x y z} a\\n\\\{ write" # Check for proper handling of unsets during traces. proc traceUnset {unsetName args} { global info upvar 1 $unsetName x lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg } proc traceReset {unsetName resetName args} { global info upvar 1 $unsetName x $resetName y lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg } proc traceReset2 {unsetName resetName args} { global info lappend info [catch {uplevel 1 unset $unsetName} msg] $msg \ [catch {uplevel 1 set $resetName xyzzy} msg] $msg } proc traceAppend {string name1 name2 op} { global info lappend info $string } test trace-16.1 {unsets during read traces} { unset -nocomplain y set y 1234 set info {} trace add variable y read {traceUnset y} trace add variable y unset {traceAppend unset} lappend info [catch {set y} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-16.2 {unsets during read traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceUnset y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} test trace-16.3 {unsets during read traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceUnset y} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} test trace-16.4 {unsets during read traces} { unset -nocomplain y set y 1234 set info {} trace add variable y read {traceReset y y} lappend info [catch {set y} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.5 {unsets during read traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset y(0) y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.6 {unsets during read traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} test trace-16.7 {unsets during read traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset2 y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} test trace-16.8 {unsets during write traces} { unset -nocomplain y set y 1234 set info {} trace add variable y write {traceUnset y} trace add variable y unset {traceAppend unset} lappend info [catch {set y xxx} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.9 {unsets during write traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceUnset y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.10 {unsets during write traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceUnset y} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.11 {unsets during write traces} { unset -nocomplain y set y 1234 set info {} trace add variable y write {traceReset y y} lappend info [catch {set y xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.12 {unsets during write traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset y(0) y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.13 {unsets during write traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} test trace-16.14 {unsets during write traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset2 y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-16.15 {unsets during unset traces} { unset -nocomplain y set y 1234 set info {} trace add variable y unset {traceUnset y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} test trace-16.16 {unsets during unset traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceUnset y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} test trace-16.17 {unsets during unset traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceUnset y} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} test trace-16.18 {unsets during unset traces} { unset -nocomplain y set y 1234 set info {} trace add variable y unset {traceReset2 y y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} test trace-16.19 {unsets during unset traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceReset2 y(0) y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} test trace-16.20 {unsets during unset traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceReset2 y y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-16.21 {unsets cancelling traces} { unset -nocomplain y set y 1234 set info {} trace add variable y read {traceAppend first} trace add variable y read {traceUnset y} trace add variable y read {traceAppend third} trace add variable y unset {traceAppend unset} lappend info [catch {set y} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-16.22 {unsets cancelling traces} { unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceAppend first} trace add variable y(0) read {traceUnset y} trace add variable y(0) read {traceAppend third} trace add variable y(0) unset {traceAppend unset} lappend info [catch {set y(0)} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} # Check various non-interference between traces and other things. test trace-17.1 {trace doesn't prevent unset errors} { unset -nocomplain x set info {} trace add variable x unset {traceProc} list [catch {unset x} msg] $msg $info } {1 {can't unset "x": no such variable} {x {} unset}} test trace-17.2 {traced variables must survive procedure exits} { unset -nocomplain x proc p1 {} {global x; trace add variable x write traceProc} p1 trace info variable x } {{write traceProc}} test trace-17.3 {traced variables must survive procedure exits} { unset -nocomplain x set info {} proc p1 {} {global x; trace add variable x write traceProc} p1 set x 44 set info } {x {} write} # Be sure that procedure frames are released before unset traces # are invoked. test trace-18.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}} set info {} p1 foo bar set info } {0 {a x y}} test trace-18.2 {namespace delete / trace vdelete combo} { namespace eval ::foo { variable x 123 |
︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 | rename doTrace {} set info } 1110 # Delete arrays when done, so they can be re-used as scalars # elsewhere. | | < | 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 | rename doTrace {} set info } 1110 # Delete arrays when done, so they can be re-used as scalars # elsewhere. unset -nocomplain x y test trace-19.0.1 {trace add command (command existence)} { # Just in case! catch {rename nosuchname ""} list [catch {trace add command nosuchname rename traceCommand} msg] $msg } {1 {unknown command "nosuchname"}} test trace-19.0.2 {trace add command (command existence in ns)} { |
︙ | ︙ | |||
1538 1539 1540 1541 1542 1543 1544 | proc foo {b} { set a $b } # Delete arrays when done, so they can be re-used as scalars # elsewhere. | | < | 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 | proc foo {b} { set a $b } # Delete arrays when done, so they can be re-used as scalars # elsewhere. unset -nocomplain x y # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} catch {rename foo {}} catch {rename bar {}} |
︙ | ︙ | |||
2046 2047 2048 2049 2050 2051 2052 | update after idle {set a "idle"} foo trace remove execution foo {enter enterstep leavestep leave} \ [list traceExecute foo] rename foo {} | | | 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 | update after idle {set a "idle"} foo trace remove execution foo {enter enterstep leavestep leave} \ [list traceExecute foo] rename foo {} unset -nocomplain a join $info "\n" } {foo foo enter foo {set a 1} enterstep foo {set a 1} 0 1 leavestep foo {update idletasks} enterstep foo {set a idle} enterstep foo {set a idle} 0 idle leavestep |
︙ | ︙ | |||
2630 2631 2632 2633 2634 2635 2636 | catch {rename foo {}} catch {rename bar {}} catch {rename untraced {}} catch {rename traceproc {}} catch {rename runbase {}} # Unset the variable when done | | < | | 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 | catch {rename foo {}} catch {rename bar {}} catch {rename untraced {}} catch {rename traceproc {}} catch {rename runbase {}} # Unset the variable when done unset -nocomplain info base # cleanup cleanupTests return |
Changes to tests/unixInit.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # The file tests the functions in the tclUnixInit.c file. # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.2 | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # The file tests the functions in the tclUnixInit.c file. # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.2 namespace import ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} # Watch out for a race condition here. If tcltest is too slow to start |
︙ | ︙ | |||
40 41 42 43 44 45 46 | test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} { # pipe1 is a connection to a server that reports what port it starts on, # and delivers a constant string to the first client to connect to that # port before exiting. set pipe1 [open "|[list [interpreter]]" r+] puts $pipe1 { proc accept {channel host port} { | | | | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} { # pipe1 is a connection to a server that reports what port it starts on, # and delivers a constant string to the first client to connect to that # port before exiting. set pipe1 [open "|[list [interpreter]]" r+] puts $pipe1 { proc accept {channel host port} { puts $channel {puts [chan configure stdin -peername]; exit} close $channel exit } puts [chan configure [socket -server accept -myaddr 127.0.0.1 0] -sockname] vwait forever \ } # Note the backslash above; this is important to make sure that the whole # string is read before an [exit] can happen... flush $pipe1 set port [lindex [gets $pipe1] 2] set sock [socket localhost $port] # pipe2 is a connection to a Tcl interpreter that takes its orders from # the socket we hand it (i.e. the server we create above.) These orders # will tell it to print out the details about the socket it is taking # instructions from, hopefully identifying it as a socket. Which is what # this test is all about. set pipe2 [open "|[list [interpreter] <@$sock]" r] set result [gets $pipe2] # Clear any pending data; stops certain kinds of (non-important) errors chan configure $pipe1 -blocking 0; gets $pipe1 chan configure $pipe2 -blocking 0; gets $pipe2 # Close the pipes and the socket. close $pipe2 close $pipe1 catch {close $sock} # Can't use normal comparison, as hostname varies due to some # installations having a messed up /etc/hosts file. if { |
︙ | ︙ | |||
325 326 327 328 329 330 331 | [file join [temporaryDirectory] tmp library] ] test unixInit-3.1 {TclpSetInitialEncodings} -constraints { unix stdio } -body { set env(LANG) C set f [open "|[list [interpreter]]" w+] | | | | 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 352 353 354 | [file join [temporaryDirectory] tmp library] ] test unixInit-3.1 {TclpSetInitialEncodings} -constraints { unix stdio } -body { set env(LANG) C set f [open "|[list [interpreter]]" w+] chan configure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f return $enc } -cleanup { unset -nocomplain env(LANG) } -match regexp -result [expr { ($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}] test unixInit-3.2 {TclpSetInitialEncodings} -setup { catch {set oldlc_all $env(LC_ALL)} } -constraints {unix stdio} -body { set env(LANG) japanese set env(LC_ALL) japanese set f [open "|[list [interpreter]]" w+] chan configure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f set validEncodings [list euc-jp] if {[string match HP-UX $tcl_platform(os)]} { # Some older HP-UX systems need us to accept this as valid Bug 453883 # reports that newer HP-UX systems report euc-jp like everybody else. |
︙ | ︙ | |||
386 387 388 389 390 391 392 | exec $tclsh $crashtest } -cleanup { removeFile crash.tcl removeFile crashtest.tcl } -returnCodes 0 # cleanup | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 | exec $tclsh $crashtest } -cleanup { removeFile crash.tcl removeFile crashtest.tcl } -returnCodes 0 # cleanup unset -nocomplain env(LANG) catch {set env(LANG) $oldlang} unset -nocomplain path ::tcltest::cleanupTests return # Local Variables: # mode: tcl # fill-column: 78 # End: |
Changes to tests/unknown.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: unknown # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | < | | | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # Commands covered: unknown # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import ::tcltest::* unset -nocomplain x catch {rename unknown unknown.old} test unknown-1.1 {non-existent "unknown" command} { list [catch {_non-existent_ foo bar} msg] $msg } {1 {invalid command name "_non-existent_"}} proc unknown {args} { |
︙ | ︙ | |||
55 56 57 58 59 60 61 | test unknown-4.1 {errors in "unknown" procedure} { list [catch {non-existent a b} msg] $msg $errorCode } {1 {unknown failed} NONE} # cleanup catch {rename unknown {}} catch {rename unknown.old unknown} | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 | test unknown-4.1 {errors in "unknown" procedure} { list [catch {non-existent a b} msg] $msg $errorCode } {1 {unknown failed} NONE} # cleanup catch {rename unknown {}} catch {rename unknown.old unknown} cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to unix/Makefile.in.
︙ | ︙ | |||
847 848 849 850 851 852 853 | $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; @echo "Installing package msgcat 1.5.0 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.5 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm; | | | | > > > > > > > > | > > > > > > > > > > > > > > > > > > > | > > | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 | $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; @echo "Installing package msgcat 1.5.0 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.5 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm; @echo "Installing package platform 1.0.11 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.11.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \ done; @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \ echo "Customizing tcl module path"; \ echo "if {![interp issafe]} { ::tcl::tm::roots {$(TCL_MODULE_PATH)} }" >> \ "$(SCRIPT_INSTALL_DIR)"/tm.tcl; \ fi install-tzdata: @for i in tzdata; \ do \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ else true; \ fi; \ done; @echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/" @for i in $(TOP_DIR)/library/tzdata/* ; do \ if [ -d $$i ] ; then \ ii=`basename $$i`; \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii ] ; then \ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \ fi; \ for j in $$i/* ; do \ if [ -d $$j ] ; then \ jj=`basename $$j`; \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj ] ; then \ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj; \ fi; \ for k in $$j/* ; do \ $(INSTALL_DATA) $$k "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj; \ done; \ else \ $(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \ fi; \ done; \ else \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/tzdata; \ fi; \ done; install-msgs: @for i in msgs; \ do \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ |
︙ | ︙ |
Changes to win/Makefile.in.
︙ | ︙ | |||
646 647 648 649 650 651 652 | do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.5.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.5 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; | | | | 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 | do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.5.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.5 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; @echo "Installing package platform 1.0.11 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.11.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ done; |
︙ | ︙ |