Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Comment: | merge trunk |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | result-helpers |
Files: | files | file ages | folders |
SHA3-256: |
3fd88cd4cdd13c15f48ea2d8d7023ffb |
User & Date: | dkf 2024-05-20 16:38:41 |
2024-05-23
| ||
08:53 | More trickery with macros Leaf check-in: a3f9c1bec2 user: dkf tags: more-macros | |
2024-05-20
| ||
16:38 | merge trunk Leaf check-in: 3fd88cd4cd user: dkf tags: result-helpers | |
2024-05-18
| ||
22:01 | Merge-mark check-in: 378a818456 user: jan.nijtmans tags: trunk, main | |
2024-05-15
| ||
14:35 |
Stop using Tcl_AppendResult to build full results
It's fine if actually appending... but we hardl... check-in: 799bc15719 user: dkf tags: result-helpers | |
Changes to generic/tcl.h.
︙ | ︙ | |||
1961 1962 1963 1964 1965 1966 1967 | * encoding type. */ Tcl_EncodingConvertProc *toUtfProc; /* Function to convert from external encoding * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ | | > | 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 | * encoding type. */ Tcl_EncodingConvertProc *toUtfProc; /* Function to convert from external encoding * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ Tcl_FreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ void *clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ Tcl_Size nullSize; /* Number of zero bytes that signify * end-of-string in this encoding. This number * is used to determine the source string * length when the srcLen argument is |
︙ | ︙ | |||
2450 2451 2452 2453 2454 2455 2456 | */ #ifndef BUILD_tcl # define ckalloc Tcl_Alloc # define attemptckalloc Tcl_AttemptAlloc # ifdef _MSC_VER /* Silence invalid C4090 warnings */ | | | | | | 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 | */ #ifndef BUILD_tcl # define ckalloc Tcl_Alloc # define attemptckalloc Tcl_AttemptAlloc # ifdef _MSC_VER /* Silence invalid C4090 warnings */ # define ckfree(a) Tcl_Free((void *)(a)) # define ckrealloc(a,b) Tcl_Realloc((void *)(a),(b)) # define attemptckrealloc(a,b) Tcl_AttemptRealloc((void *)(a),(b)) # else # define ckfree Tcl_Free # define ckrealloc Tcl_Realloc # define attemptckrealloc Tcl_AttemptRealloc # endif #endif #ifndef TCL_MEM_DEBUG /* * If we are not using the debugging allocator, we should call the Tcl_Alloc, * et al. routines in order to guarantee that every module is using the same * memory allocator both inside and outside of the Tcl library. */ # undef Tcl_InitMemory # define Tcl_InitMemory(x) # undef Tcl_DumpActiveMemory # define Tcl_DumpActiveMemory(x) # undef Tcl_ValidateAllMemory # define Tcl_ValidateAllMemory(x,y) #endif /* !TCL_MEM_DEBUG */ #ifdef TCL_MEM_DEBUG # undef Tcl_IncrRefCount # define Tcl_IncrRefCount(objPtr) \ Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__) |
︙ | ︙ |
Changes to generic/tclAlloc.c.
︙ | ︙ | |||
301 302 303 304 305 306 307 | overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); overPtr->rangeCheckMagic = RMAGIC; BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); | | | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); overPtr->rangeCheckMagic = RMAGIC; BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); return (void *)(overPtr+1); } /* * Convert amount of memory requested into closest block size stored in * hash buckets which satisfies request. Account for space used per block * for accounting. */ |
︙ | ︙ | |||
577 578 579 580 581 582 583 | */ overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); | | | 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 | */ overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); return (void *)(overPtr+1); } maxSize = (size_t)1 << (i+3); expensive = 0; if (numBytes+OVERHEAD > maxSize) { expensive = 1; } else if (i>0 && numBytes+OVERHEAD < maxSize/2) { expensive = 1; |
︙ | ︙ | |||
691 692 693 694 695 696 697 | * *---------------------------------------------------------------------- */ #undef TclpAlloc void * TclpAlloc( | | | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 | * *---------------------------------------------------------------------- */ #undef TclpAlloc void * TclpAlloc( size_t numBytes) /* Number of bytes to allocate. */ { return malloc(numBytes); } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Changes to generic/tclArithSeries.c.
︙ | ︙ | |||
93 94 95 96 97 98 99 | int *boolResult); static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj); /* ------------------------ ArithSeries object type -------------------------- */ static const Tcl_ObjType arithSeriesType = { | | | | | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | int *boolResult); static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj); /* ------------------------ ArithSeries object type -------------------------- */ static const Tcl_ObjType arithSeriesType = { "arithseries", /* name */ FreeArithSeriesInternalRep, /* freeIntRepProc */ DupArithSeriesInternalRep, /* dupIntRepProc */ UpdateStringOfArithSeries, /* updateStringProc */ SetArithSeriesFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V2( ArithSeriesObjLength, TclArithSeriesObjIndex, TclArithSeriesObjRange, TclArithSeriesObjReverse, TclArithSeriesGetElements, NULL, // SetElement |
︙ | ︙ | |||
227 228 229 230 231 232 233 | } /* *---------------------------------------------------------------------- * * ArithSeriesLen -- * | | > | | | | > | | | 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | } /* *---------------------------------------------------------------------- * * ArithSeriesLen -- * * Compute the length of the equivalent list where * every element is generated starting from *start*, * and adding *step* to generate every successive element * that's < *end* for positive steps, or > *end* for negative * steps. * * Results: * * The length of the list generated by the given range, * that may be zero. * The function returns -1 if the list is of length infinite. * * Side effects: * * None. * *---------------------------------------------------------------------- */ static Tcl_WideInt ArithSeriesLenInt( Tcl_WideInt start, Tcl_WideInt end, |
︙ | ︙ | |||
491 492 493 494 495 496 497 | /* *---------------------------------------------------------------------- * * assignNumber -- * * Create the appropriate Tcl_Obj value for the given numeric values. | | | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 | /* *---------------------------------------------------------------------- * * assignNumber -- * * Create the appropriate Tcl_Obj value for the given numeric values. * Used locally only for decoding [lseq] numeric arguments. * refcount = 0. * * Results: * * A Tcl_Obj pointer. * No assignment on error. * * Side Effects: * * None. *---------------------------------------------------------------------- */ static void |
︙ | ︙ | |||
540 541 542 543 544 545 546 | /* *---------------------------------------------------------------------- * * TclNewArithSeriesObj -- * * Creates a new ArithSeries object. Some arguments may be NULL and will * be computed based on the other given arguments. | | | | | | | | | | | 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 | /* *---------------------------------------------------------------------- * * TclNewArithSeriesObj -- * * Creates a new ArithSeries object. Some arguments may be NULL and will * be computed based on the other given arguments. * refcount = 0. * * Results: * * A Tcl_Obj pointer to the created ArithSeries object. * An empty Tcl_Obj if the range is invalid. * * Side Effects: * * None. *---------------------------------------------------------------------- */ int TclNewArithSeriesObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj **arithSeriesObj, /* return value */ int useDoubles, /* Flag indicates values start, ** end, step, are treated as doubles */ Tcl_Obj *startObj, /* Starting value */ Tcl_Obj *endObj, /* Ending limit */ Tcl_Obj *stepObj, /* increment value */ Tcl_Obj *lenObj) /* Number of elements */ { double dstart, dend, dstep; Tcl_WideInt start, end, step; Tcl_WideInt len = -1; if (startObj) { assignNumber(useDoubles, &start, &dstart, startObj); |
︙ | ︙ | |||
774 775 776 777 778 779 780 | * Tcl Panic if called. * *---------------------------------------------------------------------- */ static int SetArithSeriesFromAny( | | | | | | | | 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 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 | * Tcl Panic if called. * *---------------------------------------------------------------------- */ static int SetArithSeriesFromAny( TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */ TCL_UNUSED(Tcl_Obj *)) /* The object to convert. */ { Tcl_Panic("SetArithSeriesFromAny: should never be called"); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclArithSeriesObjRange -- * * Makes a slice of an ArithSeries value. * *arithSeriesObj must be known to be a valid list. * * Results: * Returns a pointer to the sliced series. * This may be a new object or the same object if not shared. * * Side effects: * ?The possible conversion of the object referenced by listPtr? * ?to a list object.? * *---------------------------------------------------------------------- */ int TclArithSeriesObjRange( Tcl_Interp *interp, /* For error message(s) */ Tcl_Obj *arithSeriesObj, /* List object to take a range from. */ Tcl_Size fromIdx, /* Index of first element to include. */ Tcl_Size toIdx, /* Index of last element to include. */ Tcl_Obj **newObjPtr) /* return value */ { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; (void)interp; /* silence compiler */ arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); |
︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 | * TclArithSeriesObjReverse -- * * Reverse the order of the ArithSeries value. The arithSeriesObj is * assumed to be a valid ArithSeries. The new Obj has the Start and End * values appropriately swapped and the Step value sign is changed. * * Results: | | | | | 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 | * TclArithSeriesObjReverse -- * * Reverse the order of the ArithSeries value. The arithSeriesObj is * assumed to be a valid ArithSeries. The new Obj has the Start and End * values appropriately swapped and the Step value sign is changed. * * Results: * The result will be an ArithSeries in the reverse order. * * Side effects: * The ogiginal obj will be modified and returned if it is not Shared. * *---------------------------------------------------------------------- */ int TclArithSeriesObjReverse( Tcl_Interp *interp, /* For error message(s) */ Tcl_Obj *arithSeriesObj, /* List object to reverse. */ Tcl_Obj **newObjPtr) { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; Tcl_Obj *resultObj; Tcl_WideInt start, end, step, len; |
︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 | } } else { for (i = 0; i < arithSeriesRepPtr->len; i++) { double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); char tmp[TCL_DOUBLE_SPACE + 2]; tmp[0] = 0; | | | 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 | } } else { for (i = 0; i < arithSeriesRepPtr->len; i++) { double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); char tmp[TCL_DOUBLE_SPACE + 2]; tmp[0] = 0; Tcl_PrintDouble(NULL,d,tmp); if ((bytlen + strlen(tmp)) > TCL_SIZE_MAX) { break; // overflow } bytlen += strlen(tmp); } } bytlen += arithSeriesRepPtr->len; // Space for each separator |
︙ | ︙ | |||
1182 1183 1184 1185 1186 1187 1188 | /* *---------------------------------------------------------------------- * * ArithSeriesInOperator -- * * Evaluate the "in" operation for expr * | | | | | 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 | /* *---------------------------------------------------------------------- * * ArithSeriesInOperator -- * * Evaluate the "in" operation for expr * * This can be done more efficiently in the Arith Series relative to * doing a linear search as implemented in expr. * * Results: * Boolean true or false (1/0) * * Side effects: * None * *---------------------------------------------------------------------- */ static int ArithSeriesInOperation( Tcl_Interp *interp, |
︙ | ︙ |
Changes to generic/tclAssembly.c.
︙ | ︙ | |||
218 219 220 221 222 223 224 | typedef struct AssemblyEnv { CompileEnv* envPtr; /* Compilation environment being used for code * generation */ Tcl_Parse* parsePtr; /* Parse of the current line of source */ Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose * values are 'label' objects storing the code * offsets of the labels. */ | | | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 | typedef struct AssemblyEnv { CompileEnv* envPtr; /* Compilation environment being used for code * generation */ Tcl_Parse* parsePtr; /* Parse of the current line of source */ Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose * values are 'label' objects storing the code * offsets of the labels. */ Tcl_Size cmdLine; /* Current line number within the assembly * code */ Tcl_Size* clNext; /* Invisible continuation line for * [info frame] */ BasicBlock* head_bb; /* First basic block in the code */ BasicBlock* curr_bb; /* Current basic block */ int maxDepth; /* Maximum stack depth encountered */ int curCatchDepth; /* Current depth of catches */ int maxCatchDepth; /* Maximum depth of catches encountered */ int flags; /* Compilation flags (TCL_EVAL_DIRECT) */ |
︙ | ︙ | |||
318 319 320 321 322 323 324 | */ static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep; static Tcl_DupInternalRepProc DupAssembleCodeInternalRep; static const Tcl_ObjType assembleCodeType = { "assemblecode", | | | | | | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 | */ static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep; static Tcl_DupInternalRepProc DupAssembleCodeInternalRep; static const Tcl_ObjType assembleCodeType = { "assemblecode", FreeAssembleCodeInternalRep, /* freeIntRepProc */ DupAssembleCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; /* * Source instructions recognized in the Tcl Assembly Language (TAL) */ |
︙ | ︙ | |||
847 848 849 850 851 852 853 | CompileAssembleObj( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Source code to assemble */ { Interp *iPtr = (Interp *) interp; /* Internals of the interpreter */ CompileEnv compEnv; /* Compilation environment structure */ | | > | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 | CompileAssembleObj( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Source code to assemble */ { Interp *iPtr = (Interp *) interp; /* Internals of the interpreter */ CompileEnv compEnv; /* Compilation environment structure */ ByteCode *codePtr = NULL; /* Bytecode resulting from the assembly */ Namespace* namespacePtr; /* Namespace in which variable and command * names in the bytecode resolve */ int status; /* Status return from Tcl_AssembleCode */ const char* source; /* String representation of the source code */ Tcl_Size sourceLen; /* Length of the source code in bytes */ /* |
︙ | ︙ | |||
1266 1267 1268 1269 1270 1271 1272 | TalInstType instType; /* Type of the instruction */ Tcl_Obj* operand1Obj = NULL; /* First operand to the instruction */ const char* operand1; /* String rep of the operand */ Tcl_Size operand1Len; /* String length of the operand */ int opnd; /* Integer representation of an operand */ int litIndex; /* Literal pool index of a constant */ | | | 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 | TalInstType instType; /* Type of the instruction */ Tcl_Obj* operand1Obj = NULL; /* First operand to the instruction */ const char* operand1; /* String rep of the operand */ Tcl_Size operand1Len; /* String length of the operand */ int opnd; /* Integer representation of an operand */ int litIndex; /* Literal pool index of a constant */ Tcl_Size localVar; /* LVT index of a local variable */ int flags; /* Flags for a basic block */ JumptableInfo* jtPtr; /* Pointer to a jumptable */ int infoIndex; /* Index of the jumptable in auxdata */ int status = TCL_ERROR; /* Return value from this function */ /* * Make sure that the instruction name is known at compile time. |
︙ | ︙ | |||
1961 1962 1963 1964 1965 1966 1967 | */ static int CreateMirrorJumpTable( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Obj* jumps) /* List of alternating keywords and labels */ { | | | 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 | */ static int CreateMirrorJumpTable( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Obj* jumps) /* List of alternating keywords and labels */ { Tcl_Size objc; /* Number of elements in the 'jumps' list */ Tcl_Obj** objv; /* Pointers to the elements in the list */ CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ BasicBlock* bbPtr = assemEnvPtr->curr_bb; /* Current basic block */ |
︙ | ︙ | |||
3803 3804 3805 3806 3807 3808 3809 | } /* * All blocks referenced in a jump table are successors. */ if (bbPtr->flags & BB_JUMPTABLE) { | | | 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 | } /* * All blocks referenced in a jump table are successors. */ if (bbPtr->flags & BB_JUMPTABLE) { for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch); result == TCL_OK && jtEntry != NULL; jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, TclGetString(targetLabel)); jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, |
︙ | ︙ |
Changes to generic/tclAsync.c.
︙ | ︙ | |||
26 27 28 29 30 31 32 | * invoked in the next call to * Tcl_AsyncInvoke. */ struct AsyncHandler *nextPtr, *prevPtr; /* Next, previous in list of all handlers * for the process. */ Tcl_AsyncProc *proc; /* Procedure to call when handler is * invoked. */ | | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | * invoked in the next call to * Tcl_AsyncInvoke. */ struct AsyncHandler *nextPtr, *prevPtr; /* Next, previous in list of all handlers * for the process. */ Tcl_AsyncProc *proc; /* Procedure to call when handler is * invoked. */ void *clientData; /* Value to pass to handler when it is * invoked. */ struct ThreadSpecificData *originTsd; /* Used in Tcl_AsyncMark to modify thread- * specific data from outside the thread it is * associated to. */ Tcl_ThreadId originThrdId; /* Origin thread where this token was created * and where it will be yielded. */ void *notifierData; /* Platform notifier data or NULL. */ } AsyncHandler; typedef struct ThreadSpecificData { int asyncReady; /* This is set to 1 whenever a handler becomes * ready and it is cleared to zero whenever * Tcl_AsyncInvoke is called. It can be * checked elsewhere in the application by |
︙ | ︙ | |||
138 139 140 141 142 143 144 | *---------------------------------------------------------------------- */ Tcl_AsyncHandler Tcl_AsyncCreate( Tcl_AsyncProc *proc, /* Procedure to call when handler is * invoked. */ | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | *---------------------------------------------------------------------- */ Tcl_AsyncHandler Tcl_AsyncCreate( Tcl_AsyncProc *proc, /* Procedure to call when handler is * invoked. */ void *clientData) /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); asyncPtr = (AsyncHandler*)Tcl_Alloc(sizeof(AsyncHandler)); asyncPtr->ready = 0; asyncPtr->nextPtr = NULL; |
︙ | ︙ | |||
186 187 188 189 190 191 192 | * The handler gets marked for invocation later. * *---------------------------------------------------------------------- */ void Tcl_AsyncMark( | | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | * The handler gets marked for invocation later. * *---------------------------------------------------------------------- */ void Tcl_AsyncMark( Tcl_AsyncHandler async) /* Token for handler. */ { AsyncHandler *token = (AsyncHandler *) async; Tcl_MutexLock(&asyncMutex); token->ready = 1; if (!token->originTsd->asyncActive) { token->originTsd->asyncReady = 1; |
︙ | ︙ | |||
220 221 222 223 224 225 226 | * The handler gets marked for invocation later. * *---------------------------------------------------------------------- */ int Tcl_AsyncMarkFromSignal( | | | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 | * The handler gets marked for invocation later. * *---------------------------------------------------------------------- */ int Tcl_AsyncMarkFromSignal( Tcl_AsyncHandler async, /* Token for handler. */ int sigNumber) /* Signal number. */ { #if TCL_THREADS AsyncHandler *token = (AsyncHandler *) async; return TclAsyncNotifier(sigNumber, token->originThrdId, token->notifierData, &token->ready, -1); #else |
︙ | ︙ | |||
374 375 376 377 378 379 380 | * deleted by some other thread. * *---------------------------------------------------------------------- */ void Tcl_AsyncDelete( | | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 | * deleted by some other thread. * *---------------------------------------------------------------------- */ void Tcl_AsyncDelete( Tcl_AsyncHandler async) /* Token for handler to delete. */ { AsyncHandler *asyncPtr = (AsyncHandler *) async; /* * Assure early handling of the constraint */ |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
147 148 149 150 151 152 153 | TCL_DECLARE_MUTEX(commandTypeLock); /* * Declarations for managing contexts for non-recursive coroutines. Contexts * are used to save the evaluation state between NR calls to each coro. */ | | < | | | | < | < | | | | < | 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 | TCL_DECLARE_MUTEX(commandTypeLock); /* * Declarations for managing contexts for non-recursive coroutines. Contexts * are used to save the evaluation state between NR calls to each coro. */ #define SAVE_CONTEXT(context) \ (context).framePtr = iPtr->framePtr; \ (context).varFramePtr = iPtr->varFramePtr; \ (context).cmdFramePtr = iPtr->cmdFramePtr; \ (context).lineLABCPtr = iPtr->lineLABCPtr #define RESTORE_CONTEXT(context) \ iPtr->framePtr = (context).framePtr; \ iPtr->varFramePtr = (context).varFramePtr; \ iPtr->cmdFramePtr = (context).cmdFramePtr; \ iPtr->lineLABCPtr = (context).lineLABCPtr /* * Static functions in this file: */ static Tcl_ObjCmdProc BadEnsembleSubcommand; static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, |
︙ | ︙ | |||
819 820 821 822 823 824 825 | Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } #if defined(_WIN32) && !defined(_WIN64) if (sizeof(time_t) != 8) { Tcl_Panic("<time.h> is not compatible with VS2005+"); } | | | | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 | Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } #if defined(_WIN32) && !defined(_WIN64) if (sizeof(time_t) != 8) { Tcl_Panic("<time.h> is not compatible with VS2005+"); } if ((offsetof(Tcl_StatBuf,st_atime) != 32) || (offsetof(Tcl_StatBuf,st_ctime) != 48)) { Tcl_Panic("<sys/stat.h> is not compatible with VS2005+"); } #endif if (cancelTableInitialized == 0) { Tcl_MutexLock(&cancelLock); if (cancelTableInitialized == 0) { |
︙ | ︙ | |||
903 904 905 906 907 908 909 | iPtr->returnOpts = NULL; iPtr->errorInfo = NULL; TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo"); Tcl_IncrRefCount(iPtr->eiVar); iPtr->errorStack = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(iPtr->errorStack); iPtr->resetErrorStack = 1; | | | | | 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 | iPtr->returnOpts = NULL; iPtr->errorInfo = NULL; TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo"); Tcl_IncrRefCount(iPtr->eiVar); iPtr->errorStack = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(iPtr->errorStack); iPtr->resetErrorStack = 1; TclNewLiteralStringObj(iPtr->upLiteral,"UP"); Tcl_IncrRefCount(iPtr->upLiteral); TclNewLiteralStringObj(iPtr->callLiteral,"CALL"); Tcl_IncrRefCount(iPtr->callLiteral); TclNewLiteralStringObj(iPtr->innerLiteral,"INNER"); Tcl_IncrRefCount(iPtr->innerLiteral); iPtr->innerContext = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(iPtr->innerContext); iPtr->errorCode = NULL; TclNewLiteralStringObj(iPtr->ecVar, "::errorCode"); Tcl_IncrRefCount(iPtr->ecVar); iPtr->returnLevel = 1; |
︙ | ︙ | |||
1206 1207 1208 1209 1210 1211 1212 | Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL); #endif /* USE_DTRACE */ /* * Register the builtin math functions. */ | | | 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 | Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL); #endif /* USE_DTRACE */ /* * Register the builtin math functions. */ nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL); if (nsPtr == NULL) { Tcl_Panic("Can't create math function namespace"); } #define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */ memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN); for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL; builtinFuncPtr++) { |
︙ | ︙ | |||
3684 3685 3686 3687 3688 3689 3690 | cmdPtr->nsPtr->refCount++; if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; /* CallCommandTraces() does not cmdPtr, that's * done just before Tcl_DeleteCommandFromToken() returns */ | | | 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 | cmdPtr->nsPtr->refCount++; if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; /* CallCommandTraces() does not cmdPtr, that's * done just before Tcl_DeleteCommandFromToken() returns */ CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); /* * Now delete these traces. */ tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { |
︙ | ︙ | |||
4602 4603 4604 4605 4606 4607 4608 | a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; } TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); | | < | 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 | a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; } TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); const char *a[6]; Tcl_Size i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) && objc) { |
︙ | ︙ | |||
8907 8908 8909 8910 8911 8912 8913 | } /* * Perform the tailcall */ TclMarkTailcall(interp); | | | 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 | } /* * Perform the tailcall */ TclMarkTailcall(interp); TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); iPtr->lookupNsPtr = (Namespace *) nsPtr; return TclNREvalObjv(interp, objc - 1, objv + 1, 0, NULL); } int TclNRReleaseValues( void *data[], |
︙ | ︙ | |||
9088 9089 9090 9091 9092 9093 9094 | void *clientData) { CoroutineData *corPtr = (CoroutineData *) clientData; Tcl_Interp *interp = corPtr->eePtr->interp; NRE_callback *rootPtr = TOP_CB(interp); if (COR_IS_SUSPENDED(corPtr)) { | | | 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 | void *clientData) { CoroutineData *corPtr = (CoroutineData *) clientData; Tcl_Interp *interp = corPtr->eePtr->interp; NRE_callback *rootPtr = TOP_CB(interp); if (COR_IS_SUSPENDED(corPtr)) { TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr); } } static int NRCoroutineCallerCallback( void *data[], Tcl_Interp *interp, |
︙ | ︙ | |||
9309 9310 9311 9312 9313 9314 9315 | Tcl_Size objc; Tcl_Obj **objv; Tcl_Obj *listPtr = (Tcl_Obj *) data[0]; Tcl_IncrRefCount(listPtr); TclMarkTailcall(interp); | | | 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 | Tcl_Size objc; Tcl_Obj **objv; Tcl_Obj *listPtr = (Tcl_Obj *) data[0]; Tcl_IncrRefCount(listPtr); TclMarkTailcall(interp); TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); TclListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, 0, NULL); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
9824 9825 9826 9827 9828 9829 9830 | Tcl_HashSearch hSearch; Tcl_HashEntry *hePtr; corPtr->lineLABCPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); | | | 9819 9820 9821 9822 9823 9824 9825 9826 9827 9828 9829 9830 9831 9832 9833 | Tcl_HashSearch hSearch; Tcl_HashEntry *hePtr; corPtr->lineLABCPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) { int isNew; Tcl_HashEntry *newPtr = Tcl_CreateHashEntry(corPtr->lineLABCPtr, Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr), &isNew); |
︙ | ︙ |
Changes to generic/tclBinary.c.
︙ | ︙ | |||
179 180 181 182 183 184 185 | Tcl_Size allocated; /* The amount of space actually allocated * minus 1 byte. */ unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field * above. */ } ByteArray; | < | | | < | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | Tcl_Size allocated; /* The amount of space actually allocated * minus 1 byte. */ unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_MAX_LEN (TCL_SIZE_MAX - (Tcl_Size)offsetof(ByteArray, bytes)) #define BYTEARRAY_SIZE(len) \ ( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \ ? (Tcl_Panic("negative length specified or max size of a Tcl value exceeded"), 0) \ : (offsetof(ByteArray, bytes) + (len)) ) #define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) #define SET_BYTEARRAY(irPtr, baPtr) \ (irPtr)->twoPtrValue.ptr1 = (baPtr) int TclIsPureByteArray( Tcl_Obj * objPtr) { return TclHasInternalRep(objPtr, &properByteArrayType); } |
︙ | ︙ | |||
438 439 440 441 442 443 444 | *---------------------------------------------------------------------- */ unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ Tcl_Size numBytes) /* Number of bytes in resized array | | | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 | *---------------------------------------------------------------------- */ unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ Tcl_Size numBytes) /* Number of bytes in resized array * Must be >= 0 */ { ByteArray *byteArrayPtr; Tcl_ObjInternalRep *irPtr; assert(numBytes >= 0); if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); |
︙ | ︙ | |||
734 735 736 737 738 739 740 | Tcl_Size len) { ByteArray *byteArrayPtr; Tcl_Size needed; Tcl_ObjInternalRep *irPtr; if (Tcl_IsShared(objPtr)) { | | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 | Tcl_Size len) { ByteArray *byteArrayPtr; Tcl_Size needed; Tcl_ObjInternalRep *irPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); } if (len < 0) { Tcl_Panic("%s must be called with definite number of bytes to append", "TclAppendBytesToByteArray"); } if (len == 0) { /* |
︙ | ︙ | |||
2035 2036 2037 2038 2039 2040 2041 | * valid range for float. */ if (fabs(dvalue) > (double) FLT_MAX) { if (fabs(dvalue) > (FLT_MAX + pow(2, (FLT_MAX_EXP - FLT_MANT_DIG - 1)))) { fvalue = (dvalue >= 0.0) ? INFINITY : -INFINITY; // c99 } else { | | | 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 | * valid range for float. */ if (fabs(dvalue) > (double) FLT_MAX) { if (fabs(dvalue) > (FLT_MAX + pow(2, (FLT_MAX_EXP - FLT_MANT_DIG - 1)))) { fvalue = (dvalue >= 0.0) ? INFINITY : -INFINITY; // c99 } else { fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX; } } else { fvalue = (float) dvalue; } CopyNumber(&fvalue, *cursorPtr, sizeof(float), type); *cursorPtr += sizeof(float); return TCL_OK; |
︙ | ︙ | |||
2581 2582 2583 2584 2585 2586 2587 | * Results: * The base64 encoded value prescribed by the input arguments. * *---------------------------------------------------------------------- */ #define OUTPUT(c) \ | | | | | | | | | | | | | | | 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 | * Results: * The base64 encoded value prescribed by the input arguments. * *---------------------------------------------------------------------- */ #define OUTPUT(c) \ do { \ *cursor++ = (c); \ outindex++; \ if (maxlen > 0 && cursor != limit) { \ if (outindex == maxlen) { \ memcpy(cursor, wrapchar, wrapcharlen); \ cursor += wrapcharlen; \ outindex = 0; \ } \ } \ if (cursor > limit) { \ Tcl_Panic("limit hit"); \ } \ } while (0) static int BinaryEncode64( TCL_UNUSED(void *), Tcl_Interp *interp, int objc, |
︙ | ︙ | |||
2772 2773 2774 2775 2776 2777 2778 | objv[i + 1], &wrapcharlen); { const unsigned char *p = wrapchar; Tcl_Size numBytes = wrapcharlen; while (numBytes) { switch (*p) { | | | | | | | | | | | | | | 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 | objv[i + 1], &wrapcharlen); { const unsigned char *p = wrapchar; Tcl_Size numBytes = wrapcharlen; while (numBytes) { switch (*p) { case '\t': case '\v': case '\f': case '\r': p++; numBytes--; continue; case '\n': numBytes--; break; default: goto badwrap; } } if (numBytes) { badwrap: TclSetResult(interp, "invalid wrapchar; will defeat decoding"); Tcl_SetErrorCode(interp, "TCL", "BINARY", |
︙ | ︙ |
Changes to generic/tclCkalloc.c.
︙ | ︙ | |||
167 168 169 170 171 172 173 | TclDumpMemoryInfo( void *clientData, int flags) { char buf[1024]; if (clientData == NULL) { | | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | TclDumpMemoryInfo( void *clientData, int flags) { char buf[1024]; if (clientData == NULL) { return 0; } snprintf(buf, sizeof(buf), "total mallocs %10" TCL_Z_MODIFIER "u\n" "total frees %10" TCL_Z_MODIFIER "u\n" "current packets allocated %10" TCL_Z_MODIFIER "u\n" "current bytes allocated %10" TCL_Z_MODIFIER "u\n" "maximum packets allocated %10" TCL_Z_MODIFIER "u\n" |
︙ | ︙ | |||
443 444 445 446 447 448 449 | total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) { | | | 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 | total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) { fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n", result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs); |
︙ | ︙ | |||
532 533 534 535 536 537 538 | total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) { | | | 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 | total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) { fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n", result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs); |
︙ | ︙ | |||
827 828 829 830 831 832 833 | if (result != TCL_OK) { TclPrintfResult(interp, "error accessing %s: %s", TclGetString(objv[2]), Tcl_PosixError(interp)); return TCL_ERROR; } return TCL_OK; } | | | | | | | | | | | | | | | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 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 909 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 | if (result != TCL_OK) { TclPrintfResult(interp, "error accessing %s: %s", TclGetString(objv[2]), Tcl_PosixError(interp)); return TCL_ERROR; } return TCL_OK; } if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) { Tcl_WideInt value; if (objc != 3) { goto argError; } if (TclGetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } break_on_malloc = value; return TCL_OK; } if (strcmp(TclGetString(objv[1]),"info") == 0) { TclPrintfResult(interp, "%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, "maximum bytes allocated", maximum_bytes_malloced); return TCL_OK; } if (strcmp(TclGetString(objv[1]), "init") == 0) { if (objc != 3) { goto bad_suboption; } init_malloced_bodies = (strcmp(TclGetString(objv[2]),"on") == 0); return TCL_OK; } if (strcmp(TclGetString(objv[1]), "objs") == 0) { if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "file"); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer); if (fileName == NULL) { return TCL_ERROR; } fileP = fopen(fileName, "w"); if (fileP == NULL) { TclPrintfResult(interp, "cannot open output file: %s", Tcl_PosixError(interp))); return TCL_ERROR; } TclDbDumpActiveObjects(fileP); fclose(fileP); Tcl_DStringFree(&buffer); return TCL_OK; } if (strcmp(TclGetString(objv[1]),"onexit") == 0) { if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "file"); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer); if (fileName == NULL) { return TCL_ERROR; } onExitMemDumpFileName = dumpFile; strcpy(onExitMemDumpFileName,fileName); Tcl_DStringFree(&buffer); return TCL_OK; } if (strcmp(TclGetString(objv[1]),"tag") == 0) { if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "file"); return TCL_ERROR; } if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { TclpFree(curTagPtr); } len = strlen(TclGetString(objv[2])); curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len)); curTagPtr->refCount = 0; memcpy(curTagPtr->string, TclGetString(objv[2]), len + 1); return TCL_OK; } if (strcmp(TclGetString(objv[1]),"trace") == 0) { if (objc != 3) { goto bad_suboption; } alloc_tracing = (strcmp(TclGetString(objv[2]),"on") == 0); return TCL_OK; } if (strcmp(TclGetString(objv[1]),"trace_on_at_malloc") == 0) { Tcl_WideInt value; if (objc != 3) { goto argError; } if (TclGetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } trace_on_at_malloc = value; return TCL_OK; } if (strcmp(TclGetString(objv[1]),"validate") == 0) { if (objc != 3) { goto bad_suboption; } validate_memory = (strcmp(TclGetString(objv[2]),"on") == 0); return TCL_OK; } TclPrintfResult(interp, "bad option \"%s\": should be active, break_on_malloc, info, " "init, objs, onexit, tag, trace, trace_on_at_malloc, or validate", TclGetString(objv[1]))); return TCL_ERROR; argError: Tcl_WrongNumArgs(interp, 2, objv, "count"); return TCL_ERROR; bad_suboption: |
︙ | ︙ |
Changes to generic/tclClock.c.
︙ | ︙ | |||
345 346 347 348 349 350 351 | * Results: * None. * *---------------------------------------------------------------------- */ static void ClockDeleteCmdProc( | | | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 | * Results: * None. * *---------------------------------------------------------------------- */ static void ClockDeleteCmdProc( void *clientData) /* Opaque pointer to the client data */ { ClockClientData *data = (ClockClientData *)clientData; int i; if (data->refCount-- <= 1) { for (i = 0; i < LIT__END; ++i) { Tcl_DecrRefCount(data->literals[i]); |
︙ | ︙ | |||
645 646 647 648 649 650 651 | TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, localeObj); return dataPtr->prevUsedLocale; } if ((localeObj->length == 1 /* C */ && strcasecmp(loc, Literals[LIT_C]) == 0) || (dataPtr->defaultLocale && (loc2 = TclGetString(dataPtr->defaultLocale)) | | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 | TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, localeObj); return dataPtr->prevUsedLocale; } if ((localeObj->length == 1 /* C */ && strcasecmp(loc, Literals[LIT_C]) == 0) || (dataPtr->defaultLocale && (loc2 = TclGetString(dataPtr->defaultLocale)) && localeObj->length == dataPtr->defaultLocale->length && strcasecmp(loc, loc2) == 0)) { *mcDictObj = dataPtr->defaultLocaleDict; return dataPtr->defaultLocale ? dataPtr->defaultLocale : dataPtr->literals[LIT_C]; } if (localeObj->length == 7 /* current */ |
︙ | ︙ | |||
3276 3277 3278 3279 3280 3281 3282 | } ClockOperation; static int ClockParseFmtScnArgs( ClockFmtScnCmdArgs *opts, /* Result vector: format, locale, timezone... */ TclDateFields *date, /* Extracted date-time corresponding base * (by scan or add) resp. clockval (by format) */ | | | 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 | } ClockOperation; static int ClockParseFmtScnArgs( ClockFmtScnCmdArgs *opts, /* Result vector: format, locale, timezone... */ TclDateFields *date, /* Extracted date-time corresponding base * (by scan or add) resp. clockval (by format) */ Tcl_Size objc, /* Parameter count */ Tcl_Obj *const objv[], /* Parameter vector */ ClockOperation operation, /* What operation are we doing: format, scan, add */ const char *syntax) /* Syntax of the current command */ { Tcl_Interp *interp = opts->interp; ClockClientData *dataPtr = opts->dataPtr; int gmtFlag = 0; |
︙ | ︙ | |||
3468 3469 3470 3471 3472 3473 3474 | && (!(dataPtr->lastBase.date.flags & CLF_CTZ) || dataPtr->lastTZEpoch == TzsetIfNecessary())) { memcpy(date, &dataPtr->lastBase.date, ClockCacheableDateFieldsSize); } else { /* extact fields from base */ date->seconds = baseVal; if (ClockGetDateFields(dataPtr, interp, date, opts->timezoneObj, | | | 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 | && (!(dataPtr->lastBase.date.flags & CLF_CTZ) || dataPtr->lastTZEpoch == TzsetIfNecessary())) { memcpy(date, &dataPtr->lastBase.date, ClockCacheableDateFieldsSize); } else { /* extact fields from base */ date->seconds = baseVal; if (ClockGetDateFields(dataPtr, interp, date, opts->timezoneObj, GREGORIAN_CHANGE_DATE) != TCL_OK) { /* TODO - GREGORIAN_CHANGE_DATE should be locale-dependent */ return TCL_ERROR; } /* cache last base */ memcpy(&dataPtr->lastBase.date, date, ClockCacheableDateFieldsSize); TclSetObjRef(dataPtr->lastBase.timezoneObj, opts->timezoneObj); } |
︙ | ︙ | |||
3492 3493 3494 3495 3496 3497 3498 | Tcl_SetErrorCode(interp, "CLOCK", "badOption", (i < objc) ? TclGetString(objv[i]) : (char *)NULL, (char *)NULL); return TCL_ERROR; } /*---------------------------------------------------------------------- * | | | 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 | Tcl_SetErrorCode(interp, "CLOCK", "badOption", (i < objc) ? TclGetString(objv[i]) : (char *)NULL, (char *)NULL); return TCL_ERROR; } /*---------------------------------------------------------------------- * * ClockFormatObjCmd -- , clock format -- * * This function is invoked to process the Tcl "clock format" command. * * Formats a count of seconds since the Posix Epoch as a time of day. * * The 'clock format' command formats times of day for output. Refer * to the user documentation to see what it does. |
︙ | ︙ | |||
3561 3562 3563 3564 3565 3566 3567 | done: TclUnsetObjRef(dateFmt.date.tzName); return ret; } /*---------------------------------------------------------------------- * | | | 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 | done: TclUnsetObjRef(dateFmt.date.tzName); return ret; } /*---------------------------------------------------------------------- * * ClockScanObjCmd -- , clock scan -- * * This function is invoked to process the Tcl "clock scan" command. * * Inputs a count of seconds since the Posix Epoch as a time of day. * * The 'clock scan' command scans times of day on input. Refer to the * user documentation to see what it does. |
︙ | ︙ | |||
3618 3619 3620 3621 3622 3623 3624 | ret = ClockParseFmtScnArgs(&opts, &yy.date, objc, objv, CLC_OP_SCN, "-base, -format, -gmt, -locale, -timezone or -validate"); if (ret != TCL_OK) { goto done; } /* seconds are in localSeconds (relative base date), so reset time here */ | | < | 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 | ret = ClockParseFmtScnArgs(&opts, &yy.date, objc, objv, CLC_OP_SCN, "-base, -format, -gmt, -locale, -timezone or -validate"); if (ret != TCL_OK) { goto done; } /* seconds are in localSeconds (relative base date), so reset time here */ yyHour = yyMinutes = yySeconds = yySecondOfDay = 0; yyMeridian = MER24; /* If free scan */ if (opts.formatObj == NULL) { /* Use compiled version of FreeScan - */ /* [SB] TODO: Perhaps someday we'll localize the legacy code. Right now, * it's not localized. */ |
︙ | ︙ | |||
4298 4299 4300 4301 4302 4303 4304 | } return offs; } /*---------------------------------------------------------------------- * | | | 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 | } return offs; } /*---------------------------------------------------------------------- * * ClockAddObjCmd -- , clock add -- * * Adds an offset to a given time. * * Refer to the user documentation to see what it exactly does. * * Syntax: * clock add clockval ?count unit?... ?-option value? |
︙ | ︙ | |||
4555 4556 4557 4558 4559 4560 4561 | ClockSafeCatchCmd( TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { typedef struct { | | | | | | | | | | | | 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 | ClockSafeCatchCmd( TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { typedef struct { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ int returnCode; /* struct. These fields taken together are */ Tcl_Obj *errorInfo; /* the "state" of the interp. */ Tcl_Obj *errorCode; Tcl_Obj *returnOpts; Tcl_Obj *objResult; Tcl_Obj *errorStack; int resetErrorStack; } InterpState; Interp *iPtr = (Interp *)interp; int ret, flags = 0; InterpState *statePtr; if (objc == 1) { |
︙ | ︙ |
Changes to generic/tclClockFmt.c.
︙ | ︙ | |||
628 629 630 631 632 633 634 | } /* * Type definition of clock-format tcl object type. */ static const Tcl_ObjType ClockFmtObjType = { | | | | | | | 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 | } /* * Type definition of clock-format tcl object type. */ static const Tcl_ObjType ClockFmtObjType = { "clock-format", /* name */ ClockFmtObj_FreeInternalRep, /* freeIntRepProc */ ClockFmtObj_DupInternalRep, /* dupIntRepProc */ ClockFmtObj_UpdateString, /* updateStringProc */ ClockFmtObj_SetFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; #define ObjClockFmtScn(objPtr) \ (*((ClockFmtScnStorage **)&(objPtr)->internalRep.twoPtrValue.ptr1)) #define ObjLocFmtKey(objPtr) \ |
︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 | return p; case CTOKT_WORD: c = *(tok->tokWord.start); goto findChar; case CTOKT_SPACE: | | < < | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 | return p; case CTOKT_WORD: c = *(tok->tokWord.start); goto findChar; case CTOKT_SPACE: while (!isspace(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) {} return p; case CTOKT_CHAR: c = *((char *)tok->map->data); findChar: if (!(flags & CLF_STRICT)) { /* should match the char or space */ |
︙ | ︙ | |||
2137 2138 2139 2140 2141 2142 2143 | } else { tokcnt += tokcnt; } } return ++tokcnt; } | | | | | | | | | 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 | } else { tokcnt += tokcnt; } } return ++tokcnt; } #define AllocTokenInChain(tok, chain, tokCnt, type) \ if (++(tok) >= (chain) + (tokCnt)) { \ chain = (type)Tcl_Realloc((char *)(chain), \ (tokCnt + CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE) * sizeof(*(tok))); \ (tok) = (chain) + (tokCnt); \ (tokCnt) += CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE; \ } \ memset(tok, 0, sizeof(*(tok))); /* *---------------------------------------------------------------------- */ ClockFmtScnStorage * ClockGetOrParseScanFormat( |
︙ | ︙ | |||
2290 2291 2292 2293 2294 2295 2296 | /* increase space count used in format */ fss->scnSpaceCount++; /* next token */ AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *); tokCnt++; continue; } | | | 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 | /* increase space count used in format */ fss->scnSpaceCount++; /* next token */ AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *); tokCnt++; continue; } word_tok: { /* try continue with previous word token */ ClockScanToken *wordTok = tok - 1; if (wordTok < scnTok || wordTok->map != &ScnWordTokenMap) { /* start with new word token */ wordTok = tok; |
︙ | ︙ | |||
3331 3332 3333 3334 3335 3336 3337 | /* next token */ AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *); tokCnt++; p++; continue; } default: | | > | 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 | /* next token */ AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *); tokCnt++; p++; continue; } default: word_tok: { /* try continue with previous word token */ ClockFormatToken *wordTok = tok - 1; if (wordTok < fmtTok || wordTok->map != &FmtWordTokenMap) { /* start with new word token */ wordTok = tok; wordTok->tokWord.start = p; |
︙ | ︙ |
Changes to generic/tclCmdAH.c.
︙ | ︙ | |||
401 402 403 404 405 406 407 | } /* *------------------------------------------------------------------------ * * EncodingConvertParseOptions -- * | | | | | | | | | | | | | 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 | } /* *------------------------------------------------------------------------ * * EncodingConvertParseOptions -- * * Common routine for parsing arguments passed to encoding convertfrom * and encoding convertto. * * Results: * TCL_OK or TCL_ERROR. * * Side effects: * On success, * - *encPtr is set to the encoding. Must be freed with Tcl_FreeEncoding * if non-NULL * - *dataObjPtr is set to the Tcl_Obj containing the data to encode or * decode * - *profilePtr is set to encoding error handling profile * - *failVarPtr is set to -failindex option value or NULL * On error, all of the above are uninitialized. * *------------------------------------------------------------------------ */ static int EncodingConvertParseOptions( Tcl_Interp *interp, /* For error messages. May be NULL */ int objc, /* Number of arguments */ |
︙ | ︙ | |||
520 521 522 523 524 525 526 | Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *data; /* Byte array to convert */ Tcl_DString ds; /* Buffer to hold the string */ Tcl_Encoding encoding; /* Encoding to use */ | | | 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 | Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *data; /* Byte array to convert */ Tcl_DString ds; /* Buffer to hold the string */ Tcl_Encoding encoding; /* Encoding to use */ Tcl_Size length = 0; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ int flags; int result; Tcl_Obj *failVarObj; Tcl_Size errorLocation; if (EncodingConvertParseOptions(interp, objc, objv, &encoding, &data, |
︙ | ︙ | |||
2339 2340 2341 2342 2343 2344 2345 | { Tcl_Obj *field, *value, *result; unsigned short mode; if (varName == NULL) { TclNewObj(result); Tcl_IncrRefCount(result); | | | | | | | | | | | < | 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 | { Tcl_Obj *field, *value, *result; unsigned short mode; if (varName == NULL) { TclNewObj(result); Tcl_IncrRefCount(result); #define DOBJPUT(key, objValue) \ Tcl_DictObjPut(NULL, result, \ Tcl_NewStringObj((key), -1), \ (objValue)); DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev)); DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink)); DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid)); DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid)); DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); #ifdef HAVE_STRUCT_STAT_ST_BLOCKS DOBJPUT("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); #endif #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE DOBJPUT("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize)); #endif DOBJPUT("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); DOBJPUT("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); DOBJPUT("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); mode = (unsigned short) statPtr->st_mode; DOBJPUT("mode", Tcl_NewWideIntObj(mode)); DOBJPUT("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); #undef DOBJPUT Tcl_SetObjResult(interp, result); Tcl_DecrRefCount(result); return TCL_OK; } /* * Might be a better idea to call Tcl_SetVar2Ex() instead, except we want * to have an object (i.e. possibly cached) array variable name but a * string element name, so no API exists. Messy. */ #define STORE_ARY(fieldName, object) \ TclNewLiteralStringObj(field, fieldName); \ Tcl_IncrRefCount(field); \ value = (object); \ if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \ TclDecrRefCount(field); \ return TCL_ERROR; \ } \ TclDecrRefCount(field); /* * Watch out porters; the inode is meant to be an *unsigned* value, so the |
︙ | ︙ | |||
2826 2827 2828 2829 2830 2831 2832 | result = TCL_ERROR; goto done; } TclListObjGetElements(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); /* Values */ | | | 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 | result = TCL_ERROR; goto done; } TclListObjGetElements(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); /* Values */ if (TclObjTypeHasProc(objv[2+i*2],indexProc)) { /* Special case for AbstractList */ statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]); if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; } /* Don't compute values here, wait until the last moment */ |
︙ | ︙ | |||
2976 2977 2978 2979 2980 2981 2982 | { int i; Tcl_Size v, k; Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; i<statePtr->numLists ; i++) { int isAbstractList = | | | 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 | { int i; Tcl_Size v, k; Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; i<statePtr->numLists ; i++) { int isAbstractList = TclObjTypeHasProc(statePtr->aCopyList[i],indexProc) != NULL; for (v=0 ; v<statePtr->varcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { if (isAbstractList) { if (TclObjTypeIndex(interp, statePtr->aCopyList[i], k, &valuePtr) != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
︙ | ︙ |
Changes to generic/tclCmdIL.c.
︙ | ︙ | |||
781 782 783 784 785 786 787 | if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { | | | 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 | if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); } } entryPtr = Tcl_NextHashEntry(&search); } } |
︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 | Tcl_Obj * TclInfoFrame( Tcl_Interp *interp, /* Current interpreter. */ CmdFrame *framePtr) /* Frame to get info for. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *tmpObj; | | | | | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 | Tcl_Obj * TclInfoFrame( Tcl_Interp *interp, /* Current interpreter. */ CmdFrame *framePtr) /* Frame to get info for. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *tmpObj; Tcl_Obj *lv[20] = {NULL}; /* Keep uptodate when more keys are added to * the dict. */ int lc = 0; /* * This array is indexed by the TCL_LOCATION_... values, except * for _LAST. */ static const char *const typeString[TCL_LOCATION_LAST] = { "eval", "eval", "eval", "precompiled", "source", "proc" }; Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; int needsFree = -1; /* * Pull the information and construct the dictionary to return, as list. * Regarding use of the CmdFrame fields see tclInt.h, and its definition. */ #define ADD_PAIR(name, value) \ TclNewLiteralStringObj(tmpObj, name); \ lv[lc++] = tmpObj; \ lv[lc++] = (value) switch (framePtr->type) { case TCL_LOCATION_EVAL: /* * Evaluation, dynamic script. Type, line, cmd, the latter through * str. |
︙ | ︙ | |||
2412 2413 2414 2415 2416 2417 2418 | *---------------------------------------------------------------------- */ int Tcl_LinsertObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ | | | 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 | *---------------------------------------------------------------------- */ int Tcl_LinsertObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *listPtr; Tcl_Size len, index; int copied = 0, result; if (objc < 3) { |
︙ | ︙ | |||
2505 2506 2507 2508 2509 2510 2511 | *---------------------------------------------------------------------- */ int Tcl_ListObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ | | | > | 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 | *---------------------------------------------------------------------- */ int Tcl_ListObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { /* * If there are no list elements, the result is an empty object. * Otherwise set the interpreter's result object to be a list object. */ if (objc > 1) { |
︙ | ︙ | |||
2541 2542 2543 2544 2545 2546 2547 | */ int Tcl_LlengthObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ | | > | 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 | */ int Tcl_LlengthObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Size listLen; int result; Tcl_Obj *objPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); |
︙ | ︙ | |||
2589 2590 2591 2592 2593 2594 2595 | */ int Tcl_LpopObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ | | > | 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 | */ int Tcl_LpopObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Size listLen; int copied = 0, result; Tcl_Obj *elemPtr, *stored; Tcl_Obj *listPtr; if (objc < 2) { |
︙ | ︙ | |||
2707 2708 2709 2710 2711 2712 2713 | */ int Tcl_LrangeObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ | | > | 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 | */ int Tcl_LrangeObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int result; Tcl_Size listLen, first, last; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; } |
︙ | ︙ | |||
2918 2919 2920 2921 2922 2923 2924 | *---------------------------------------------------------------------- */ int Tcl_LrepeatObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ | | | > | 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 | *---------------------------------------------------------------------- */ int Tcl_LrepeatObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_WideInt elementCount, i; Tcl_Size totalElems; Tcl_Obj *listPtr, **dataArray = NULL; /* * Check arguments for legality: |
︙ | ︙ | |||
3849 3850 3851 3852 3853 3854 3855 | } goto done; } match = (objWide == patWide); break; case REAL: | | | 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 | } goto done; } match = (objWide == patWide); break; case REAL: result = Tcl_GetDoubleFromObj(interp,itemPtr, &objDouble); if (result != TCL_OK) { if (listPtr) { Tcl_DecrRefCount(listPtr); } goto done; } match = (objDouble == patDouble); |
︙ | ︙ | |||
4009 4010 4011 4012 4013 4014 4015 | * * The decoded value will be assigned to the appropriate * pointer, if supplied. */ static SequenceDecoded SequenceIdentifyArgument( | | | | | | 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 | * * The decoded value will be assigned to the appropriate * pointer, if supplied. */ static SequenceDecoded SequenceIdentifyArgument( Tcl_Interp *interp, /* for error reporting */ Tcl_Obj *argPtr, /* Argument to decode */ Tcl_Obj **numValuePtr, /* Return numeric value */ int *keywordIndexPtr) /* Return keyword enum */ { int status; SequenceOperators opmode; SequenceByMode bymode; void *clientData; status = Tcl_GetNumberFromObj(NULL, argPtr, &clientData, keywordIndexPtr); |
︙ | ︙ | |||
4144 4145 4146 4147 4148 4149 4150 | /* * Create a decoding key by looping through the arguments and identify * what kind of argument each one is. Encode each argument as a decimal * digit. */ if (objc > 6) { | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | > > | > | > | | | | > | 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 | /* * Create a decoding key by looping through the arguments and identify * what kind of argument each one is. Encode each argument as a decimal * digit. */ if (objc > 6) { /* Too many arguments */ arg_key=0; } else for (i=1; i<objc; i++) { arg_key = (arg_key * 10); numValues[value_i] = NULL; decoded = SequenceIdentifyArgument(interp, objv[i], &numberObj, &keyword); switch (decoded) { case NoneArg: /* * Unrecognizable argument * Reproduce operation error message */ status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations, "operation", 0, &opmode); goto done; case NumericArg: arg_key += NumericArg; numValues[value_i] = numberObj; Tcl_IncrRefCount(numValues[value_i]); values[value_i] = keyword; // This is the TCL_NUMBER_* value useDoubles = useDoubles ? useDoubles : keyword == TCL_NUMBER_DOUBLE; value_i++; break; case RangeKeywordArg: arg_key += RangeKeywordArg; values[value_i] = keyword; value_i++; break; case ByKeywordArg: arg_key += ByKeywordArg; values[value_i] = keyword; value_i++; break; default: arg_key += 9; // Error state value_i++; break; } } /* * The key encoding defines a valid set of arguments, or indicates an * error condition; process the values accordningly. */ switch (arg_key) { /* No argument */ case 0: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); goto done; break; /* lseq n */ case 1: start = zero; elementCount = numValues[0]; end = NULL; step = one; break; /* lseq n n */ case 11: start = numValues[0]; end = numValues[1]; break; /* lseq n n n */ case 111: start = numValues[0]; end = numValues[1]; step = numValues[2]; break; /* lseq n 'to' n */ /* lseq n 'count' n */ /* lseq n 'by' n */ case 121: opmode = (SequenceOperators)values[1]; switch (opmode) { case LSEQ_DOTS: case LSEQ_TO: start = numValues[0]; end = numValues[2]; break; |
︙ | ︙ | |||
4242 4243 4244 4245 4246 4247 4248 | step = one; break; default: goto done; } break; | | | > | 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 | step = one; break; default: goto done; } break; /* lseq n 'to' n n */ /* lseq n 'count' n n */ case 1211: opmode = (SequenceOperators)values[1]; switch (opmode) { case LSEQ_DOTS: case LSEQ_TO: start = numValues[0]; end = numValues[2]; step = numValues[3]; |
︙ | ︙ | |||
4267 4268 4269 4270 4271 4272 4273 | break; default: goto done; break; } break; | > | | | > | 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 | break; default: goto done; break; } break; /* lseq n n 'by' n */ case 1121: start = numValues[0]; end = numValues[1]; opmode = (SequenceOperators)values[2]; switch (opmode) { case LSEQ_BY: step = numValues[3]; break; case LSEQ_DOTS: case LSEQ_TO: case LSEQ_COUNT: default: goto done; break; } break; /* lseq n 'to' n 'by' n */ /* lseq n 'count' n 'by' n */ case 12121: start = numValues[0]; opmode = (SequenceOperators)values[3]; switch (opmode) { case LSEQ_BY: step = numValues[4]; break; default: |
︙ | ︙ | |||
4313 4314 4315 4316 4317 4318 4319 | break; default: goto done; break; } break; | | > | < | < | > | > > | | 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 | break; default: goto done; break; } break; /* Error cases: incomplete arguments */ case 12: opmode = (SequenceOperators)values[1]; goto KeywordError; break; case 112: opmode = (SequenceOperators)values[2]; goto KeywordError; break; case 1212: opmode = (SequenceOperators)values[3]; goto KeywordError; break; KeywordError: switch (opmode) { case LSEQ_DOTS: case LSEQ_TO: TclSetResult(interp, "missing \"to\" value."); break; case LSEQ_COUNT: TclSetResult(interp, "missing \"count\" value."); break; case LSEQ_BY: TclSetResult(interp, "missing \"by\" value."); break; } goto done; break; /* All other argument errors */ default: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); goto done; break; } /* * Success! Now lets create the series object. */ status = TclNewArithSeriesObj(interp, &arithSeriesPtr, useDoubles, start, end, step, elementCount); if (status == TCL_OK) { Tcl_SetObjResult(interp, arithSeriesPtr); } done: // Free number arguments. |
︙ | ︙ | |||
4422 4423 4424 4425 4426 4427 4428 | */ if (objc == 4) { finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); } else { if (TclObjTypeHasProc(listPtr, setElementProc)) { finalValuePtr = TclObjTypeSetElement(interp, listPtr, | | | | | 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 | */ if (objc == 4) { finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); } else { if (TclObjTypeHasProc(listPtr, setElementProc)) { finalValuePtr = TclObjTypeSetElement(interp, listPtr, objc-3, objv+2, objv[objc-1]); if (finalValuePtr) { Tcl_IncrRefCount(finalValuePtr); } } else { finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, objv[objc-1]); } } /* * If substitution has failed, bail out. */ |
︙ | ︙ |
Changes to generic/tclCmdMZ.c.
︙ | ︙ | |||
1241 1242 1243 1244 1245 1246 1247 | /* * Handle the special case of splitting on a single character. This is * only true for the one-char ASCII case, as one Unicode char is > 1 * byte in length. */ | | | 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 | /* * Handle the special case of splitting on a single character. This is * only true for the one-char ASCII case, as one Unicode char is > 1 * byte in length. */ while (*stringPtr && (p=strchr(stringPtr,*splitChars)) != NULL) { objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); stringPtr = p + 1; } TclNewStringObj(objPtr, stringPtr, end - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { |
︙ | ︙ | |||
2401 2402 2403 2404 2405 2406 2407 | /* * The following test screens out most empty substrings as candidates for * replacement. When they are detected, no replacement is done, and the * result is the original string. */ | | | 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 | /* * The following test screens out most empty substrings as candidates for * replacement. When they are detected, no replacement is done, and the * result is the original string. */ if ((last < 0) || /* Range ends before start of string */ (first > end) || /* Range begins after end of string */ (last < first)) { /* Range begins after it starts */ /* * BUT!!! when (end < 0) -- an empty original string -- we can * have (first <= end < 0 <= last) and an empty string is permitted * to be replaced. */ |
︙ | ︙ | |||
2899 2900 2901 2902 2903 2904 2905 | Tcl_SetObjResult(interp, resultPtr); } else { Tcl_Size first, last; const char *start, *end; Tcl_Obj *resultPtr; length1 = Tcl_NumUtfChars(string1, length1) - 1; | | | 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 | Tcl_SetObjResult(interp, resultPtr); } else { Tcl_Size first, last; const char *start, *end; Tcl_Obj *resultPtr; length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } if (first < 0) { first = 0; } last = first; |
︙ | ︙ | |||
2984 2985 2986 2987 2988 2989 2990 | Tcl_SetObjResult(interp, resultPtr); } else { Tcl_Size first, last; const char *start, *end; Tcl_Obj *resultPtr; length1 = Tcl_NumUtfChars(string1, length1) - 1; | | | 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 | Tcl_SetObjResult(interp, resultPtr); } else { Tcl_Size first, last; const char *start, *end; Tcl_Obj *resultPtr; length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } if (first < 0) { first = 0; } last = first; |
︙ | ︙ | |||
3069 3070 3071 3072 3073 3074 3075 | Tcl_SetObjResult(interp, resultPtr); } else { Tcl_Size first, last; const char *start, *end; Tcl_Obj *resultPtr; length1 = Tcl_NumUtfChars(string1, length1) - 1; | | | 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 | Tcl_SetObjResult(interp, resultPtr); } else { Tcl_Size first, last; const char *start, *end; Tcl_Obj *resultPtr; length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } if (first < 0) { first = 0; } last = first; |
︙ | ︙ | |||
3693 3694 3695 3696 3697 3698 3699 | switch (mode) { case OPT_EXACT: if (strCmpFn(TclGetString(stringObj), pattern) == 0) { goto matchFound; } break; case OPT_GLOB: | | | 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 | switch (mode) { case OPT_EXACT: if (strCmpFn(TclGetString(stringObj), pattern) == 0) { goto matchFound; } break; case OPT_GLOB: if (Tcl_StringCaseMatch(TclGetString(stringObj),pattern,noCase)) { goto matchFound; } break; case OPT_REGEXP: regExpr = Tcl_GetRegExpFromObj(interp, objv[i], TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); if (regExpr == NULL) { |
︙ | ︙ | |||
5297 5298 5299 5300 5301 5302 5303 | TclListLines( Tcl_Obj *listObj, /* Pointer to obj holding a string with list * structure. Assumed to be valid. Assumed to * contain n elements. */ Tcl_Size line, /* Line the list as a whole starts on. */ Tcl_Size n, /* #elements in lines */ Tcl_Size *lines, /* Array of line numbers, to fill. */ | | | 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 | TclListLines( Tcl_Obj *listObj, /* Pointer to obj holding a string with list * structure. Assumed to be valid. Assumed to * contain n elements. */ Tcl_Size line, /* Line the list as a whole starts on. */ Tcl_Size n, /* #elements in lines */ Tcl_Size *lines, /* Array of line numbers, to fill. */ Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of * derived continuation data */ { const char *listStr = TclGetString(listObj); const char *listHead = listStr; Tcl_Size i, length = strlen(listStr); const char *element = NULL, *next = NULL; ContLineLoc *clLocPtr = TclContinuationsGet(listObj); |
︙ | ︙ |
Changes to generic/tclCompCmds.c.
︙ | ︙ | |||
375 376 377 378 379 380 381 | * a non-local variable: upvar from a local one! This consumes the * variable name that was left at stacktop. */ localIndex = TclFindCompiledLocal(varTokenPtr->start, varTokenPtr->size, 1, envPtr); PushStringLiteral(envPtr, "0"); | | | < | | < | 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 | * a non-local variable: upvar from a local one! This consumes the * variable name that was left at stacktop. */ localIndex = TclFindCompiledLocal(varTokenPtr->start, varTokenPtr->size, 1, envPtr); PushStringLiteral(envPtr, "0"); TclEmitInstInt4(INST_REVERSE, 2, envPtr); TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); TclEmitOpcode(INST_POP, envPtr); } /* * Prepare for the internal foreach. */ keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(Tcl_Size)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr); /* * Start issuing instructions to write to the array. |
︙ | ︙ | |||
965 966 967 968 969 970 971 | &localIndex, &isScalar, 1); /* * If the user specified an array element, we don't bother handling * that. */ if (!isScalar) { | | | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 | &localIndex, &isScalar, 1); /* * If the user specified an array element, we don't bother handling * that. */ if (!isScalar) { return TCL_ERROR; } /* * We are doing an assignment to set the value of the constant. This will * need to be extended to push a value for each argument. */ |
︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 | Tcl_Size numBytes; int code; Tcl_Token *incrTokenPtr; Tcl_Obj *intObj; incrTokenPtr = TokenAfter(keyTokenPtr); if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { | | | | 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 | Tcl_Size numBytes; int code; Tcl_Token *incrTokenPtr; Tcl_Obj *intObj; incrTokenPtr = TokenAfter(keyTokenPtr); if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); } word = incrTokenPtr[1].start; numBytes = incrTokenPtr[1].size; intObj = Tcl_NewStringObj(word, numBytes); Tcl_IncrRefCount(intObj); code = TclGetIntFromObj(NULL, intObj, &incrAmount); TclDecrRefCount(intObj); if (code != TCL_OK) { return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); } } else { incrAmount = 1; } /* * The dictionary variable must be a local scalar that is knowable at |
︙ | ︙ | |||
1997 1998 1999 2000 2001 2002 2003 | /* * Get the index of the local variable that we will be working with. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); if (dictVarIndex < 0) { | | | 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 | /* * Get the index of the local variable that we will be working with. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); if (dictVarIndex < 0) { return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr); } /* * Produce the string to concatenate onto the dictionary entry. */ tokenPtr = TokenAfter(tokenPtr); |
︙ | ︙ | |||
2963 2964 2965 2966 2967 2968 2969 | * the new ForeachInfo record. * *---------------------------------------------------------------------- */ static void * DupForeachInfo( | | | 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 | * the new ForeachInfo record. * *---------------------------------------------------------------------- */ static void * DupForeachInfo( void *clientData) /* The foreach command's compilation auxiliary * data to duplicate. */ { ForeachInfo *srcPtr = (ForeachInfo *)clientData; ForeachInfo *dupPtr; ForeachVarList *srcListPtr, *dupListPtr; int numVars, i, j, numLists = srcPtr->numLists; |
︙ | ︙ | |||
3012 3013 3014 3015 3016 3017 3018 | * ForeachInfo structure. * *---------------------------------------------------------------------- */ static void FreeForeachInfo( | | | 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 | * ForeachInfo structure. * *---------------------------------------------------------------------- */ static void FreeForeachInfo( void *clientData) /* The foreach command's compilation auxiliary * data to free. */ { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *listPtr; size_t i, numLists = infoPtr->numLists; for (i = 0; i < numLists; i++) { |
︙ | ︙ | |||
3346 3347 3348 3349 3350 3351 3352 | i = 0; /* The count of things to concat. */ j = 2; /* The index into the argument tokens, for * TIP#280 handling. */ start = TclGetString(formatObj); /* The start of the currently-scanned literal * in the format string. */ | | | 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 | i = 0; /* The count of things to concat. */ j = 2; /* The index into the argument tokens, for * TIP#280 handling. */ start = TclGetString(formatObj); /* The start of the currently-scanned literal * in the format string. */ TclNewObj(tmpObj); /* The buffer used to accumulate the literal * being built. */ for (bytes = start ; *bytes ; bytes++) { if (*bytes == '%') { Tcl_AppendToObj(tmpObj, start, bytes - start); if (*++bytes == '%') { Tcl_AppendToObj(tmpObj, "%", 1); } else { |
︙ | ︙ | |||
3448 3449 3450 3451 3452 3453 3454 | TclLocalScalar( const char *bytes, size_t numBytes, CompileEnv *envPtr) { Tcl_Token token[2] = { {TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, | | | 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 | TclLocalScalar( const char *bytes, size_t numBytes, CompileEnv *envPtr) { Tcl_Token token[2] = { {TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, {TCL_TOKEN_TEXT, NULL, 0, 0} }; token[1].start = bytes; token[1].size = numBytes; return TclLocalScalarFromToken(token, envPtr); } |
︙ | ︙ | |||
3596 3597 3598 3599 3600 3601 3602 | name = varTokenPtr[1].start; nameLen = p - varTokenPtr[1].start; elName = p + 1; remainingLen = (varTokenPtr[2].start - p) - 1; elNameLen = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1; if (!(flags & TCL_NO_ELEMENT)) { | | | | | | | < | | | | | | | | | | | | | | | | | | | 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 | name = varTokenPtr[1].start; nameLen = p - varTokenPtr[1].start; elName = p + 1; remainingLen = (varTokenPtr[2].start - p) - 1; elNameLen = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1; if (!(flags & TCL_NO_ELEMENT)) { if (remainingLen) { /* * Make a first token with the extra characters in the first * token. */ elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, n * sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; elemTokenPtr->size = remainingLen; elemTokenPtr->numComponents = 0; elemTokenCount = n; /* * Copy the remaining tokens. */ memcpy(elemTokenPtr+1, varTokenPtr+2, (n-1) * sizeof(Tcl_Token)); } else { /* * Use the already available tokens. */ elemTokenPtr = &varTokenPtr[2]; elemTokenCount = n - 1; } } } } if (simpleVarName) { /* * See whether name has any namespace separators (::'s). |
︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
︙ | ︙ | |||
519 520 521 522 523 524 525 | haveImmValue = 1; } /* * Emit the instruction to increment the variable. */ | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 | haveImmValue = 1; } /* * Emit the instruction to increment the variable. */ if (isScalar) { /* Simple scalar variable. */ if (localIndex >= 0) { if (haveImmValue) { TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); } |
︙ | ︙ | |||
2020 2021 2022 2023 2024 2025 2026 | * Attempt to convert pattern to glob. If successful, push the * converted pattern as a literal. */ if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL) == TCL_OK) { simple = 1; | | | 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 | * Attempt to convert pattern to glob. If successful, push the * converted pattern as a literal. */ if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL) == TCL_OK) { simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } } if (!simple) { CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 2); } |
︙ | ︙ | |||
2204 2205 2206 2207 2208 2209 2210 | goto done; } bytes++; } isSimpleGlob: for (bytes = TclGetString(replacementObj); *bytes; bytes++) { switch (*bytes) { | | < | 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 | goto done; } bytes++; } isSimpleGlob: for (bytes = TclGetString(replacementObj); *bytes; bytes++) { switch (*bytes) { case '\\': case '&': goto done; } } /* * Proved the simplicity constraints! Time to issue the code. */ |
︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
︙ | ︙ | |||
1125 1126 1127 1128 1129 1130 1131 | OP( POP); /* Pop newString */ } /* Original string argument now on TOS as result */ return TCL_OK; } if (parsePtr->numWords == 5) { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | OP( POP); /* Pop newString */ } /* Original string argument now on TOS as result */ return TCL_OK; } if (parsePtr->numWords == 5) { /* * When we have a string replacement, we have to take care about * not replacing empty substrings that [string replace] promises * not to replace * * The remaining index values might be suitable for conventional * string replacement, but only if they cannot possibly meet the * conditions described above at runtime. If there's a chance they * might, we would have to emit bytecode to check and at that point * we're paying more in bytecode execution time than would make * things worthwhile. Trouble is we are very limited in * how much we can detect that at compile time. After decoding, * we need, first: * * (first <= end) * * The encoded indices (first <= TCL_INDEX END) and * (first == TCL_INDEX_NONE) always meets this condition, but * any other encoded first index has some list for which it fails. * * We also need, second: * * (last >= 0) * * The encoded index (last >= TCL_INDEX_START) always meet this * condition but any other encoded last index has some list for * which it fails. * * Finally we need, third: * * (first <= last) * * Considered in combination with the constraints we already have, * we see that we can proceed when (first == TCL_INDEX_NONE). * These also permit simplification of the prefix|replace|suffix * construction. The other constraints, though, interfere with * getting a guarantee that first <= last. */ if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) { /* empty prefix */ tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP4( REVERSE, 2); if (last == INT_MAX) { OP( POP); /* Pop original */ } else { OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); OP1( STR_CONCAT1, 2); } return TCL_OK; } if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) { OP44( STR_RANGE_IMM, 0, first-1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP1( STR_CONCAT1, 2); return TCL_OK; } /* FLOW THROUGH TO genericReplace */ } else { /* * When we have no replacement string to worry about, we may * have more luck, because the forbidden empty string replacements |
︙ | ︙ | |||
1470 1471 1472 1473 1474 1475 1476 | if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { objc++; goto cleanup; } wordTokenPtr = TokenAfter(wordTokenPtr); } | < > < > | 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 | if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { objc++; goto cleanup; } wordTokenPtr = TokenAfter(wordTokenPtr); } /* if (TclSubstOptions(NULL, numOpts, objv, &flags) == TCL_OK) { toSubst = objv[numOpts]; Tcl_IncrRefCount(toSubst); } */ /* TODO: Figure out expansion to cover WordKnownAtCompileTime * The difficulty is that WKACT makes a copy, and if TclSubstParse * below parses the copy of the original source string, some deep * parts of the compile machinery get upset. They want all pointers * stored in Tcl_Tokens to point back to the same original string. */ |
︙ | ︙ | |||
2111 2112 2113 2114 2115 2116 2117 | CompileEnv *envPtr, /* Holds resulting instructions. */ int mode, /* Exact, Glob or Regexp */ int noCase, /* Case-insensitivity flag. */ Tcl_Size numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ | | | < | 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 | CompileEnv *envPtr, /* Holds resulting instructions. */ int mode, /* Exact, Glob or Regexp */ int noCase, /* Case-insensitivity flag. */ Tcl_Size numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ Tcl_Size *bodyLines, /* Array of line numbers for body list * items. */ Tcl_Size **bodyContLines) /* Array of continuation line info. */ { enum {Switch_Exact, Switch_Glob, Switch_Regexp}; int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ unsigned int *fixupTargetArray; /* Array of places for fixups to point at. */ int fixupCount; /* Number of places to fix up. */ int contFixIndex; /* Where the first of the jumps due to a group * of continuation bodies starts, or -1 if * there aren't any. */ int contFixCount; /* Number of continuation bodies pointing to * the current (or next) real body. */ int nextArmFixupIndex; |
︙ | ︙ | |||
2360 2361 2362 2363 2364 2365 2366 | IssueSwitchJumpTable( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ | | | 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 | IssueSwitchJumpTable( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ Tcl_Size *bodyLines, /* Array of line numbers for body list * items. */ Tcl_Size **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; int mustGenerate, foundDefault, jumpToDefault, i; Tcl_DString buffer; |
︙ | ︙ |
Changes to generic/tclCompExpr.c.
︙ | ︙ | |||
742 743 744 745 746 747 748 | * When we compile the expression we'll need the function * name, and there's no place in the parse tree to store * it, so we keep a separate list of all the function * names we've parsed in the order we found them. */ Tcl_ListObjAppendElement(NULL, funcList, literal); | | | 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 | * When we compile the expression we'll need the function * name, and there's no place in the parse tree to store * it, so we keep a separate list of all the function * names we've parsed in the order we found them. */ Tcl_ListObjAppendElement(NULL, funcList, literal); } else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) { lexeme = BOOLEAN; } else { /* * Tricky case: see test expr-62.10 */ int scanned2 = scanned; |
︙ | ︙ | |||
1865 1866 1867 1868 1869 1870 1871 | * first null character. */ Tcl_Parse *parsePtr) /* Structure to fill with information about * the parsed expression; any previous * information in the structure is ignored. */ { int code; OpNode *opTree = NULL; /* Will point to the tree of operators. */ | | | | 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 | * first null character. */ Tcl_Parse *parsePtr) /* Structure to fill with information about * the parsed expression; any previous * information in the structure is ignored. */ { int code; OpNode *opTree = NULL; /* Will point to the tree of operators. */ Tcl_Obj *litList; /* List to hold the literals. */ Tcl_Obj *funcList; /* List to hold the functon names. */ Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions. */ TclNewObj(litList); TclNewObj(funcList); if (numBytes < 0) { numBytes = (start ? strlen(start) : 0); |
︙ | ︙ |
Changes to generic/tclCompile.c.
︙ | ︙ | |||
393 394 395 396 397 398 399 | /* Make array element cease to exist; element is stktop, array name is * stknext; op1 is 1 for errors on problems, 0 otherwise */ {"unsetStk", 2, -1, 1, {OPERAND_UINT1}}, /* Make general variable cease to exist; unparsed variable name is * stktop; op1 is 1 for errors on problems, 0 otherwise */ {"dictExpand", 1, -1, 0, {OPERAND_NONE}}, | | | | | | | | | 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 | /* Make array element cease to exist; element is stktop, array name is * stknext; op1 is 1 for errors on problems, 0 otherwise */ {"unsetStk", 2, -1, 1, {OPERAND_UINT1}}, /* Make general variable cease to exist; unparsed variable name is * stktop; op1 is 1 for errors on problems, 0 otherwise */ {"dictExpand", 1, -1, 0, {OPERAND_NONE}}, /* Probe into a dict and extract it (or a subdict of it) into * variables with matched names. Produces list of keys bound as * result. Part of [dict with]. * Stack: ... dict path => ... keyList */ {"dictRecombineStk", 1, -3, 0, {OPERAND_NONE}}, /* Map variable contents back into a dictionary in a variable. Part of * [dict with]. * Stack: ... dictVarName path keyList => ... */ {"dictRecombineImm", 5, -2, 1, {OPERAND_LVT4}}, /* Map variable contents back into a dictionary in the local variable * indicated by the LVT index. Part of [dict with]. * Stack: ... path keyList => ... */ {"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* The top op4 words (min 1) are a key path into the dictionary just * below the keys on the stack, and all those values are replaced by a * boolean indicating whether it is possible to read out a value from * that key-path (like [dict exists]). * Stack: ... dict key1 ... keyN => ... boolean */ |
︙ | ︙ | |||
633 634 635 636 637 638 639 | /* Lappend list to array element. * Stack: ... arrayName elem list => ... listVarContents */ {"lappendListStk", 1, -1, 0, {OPERAND_NONE}}, /* Lappend list to general variable. * Stack: ... varName list => ... listVarContents */ {"clockRead", 2, +1, 1, {OPERAND_UINT1}}, | | | 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 | /* Lappend list to array element. * Stack: ... arrayName elem list => ... listVarContents */ {"lappendListStk", 1, -1, 0, {OPERAND_NONE}}, /* Lappend list to general variable. * Stack: ... varName list => ... listVarContents */ {"clockRead", 2, +1, 1, {OPERAND_UINT1}}, /* Read clock out to the stack. Operand is which clock to read * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds. * Stack: ... => ... time */ {"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* The top word is the default, the next op4 words (min 1) are a key * path into the dictionary just below the keys on the stack, and all * those values are replaced by the value read out of that key-path |
︙ | ︙ | |||
775 776 777 778 779 780 781 | int TclSetByteCodeFromAny( Tcl_Interp *interp, /* The interpreter for which the code is being * compiled. Must not be NULL. */ Tcl_Obj *objPtr, /* The object to make a ByteCode object. */ CompileHookProc *hookProc, /* Procedure to invoke after compilation. */ | | | 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 | int TclSetByteCodeFromAny( Tcl_Interp *interp, /* The interpreter for which the code is being * compiled. Must not be NULL. */ Tcl_Obj *objPtr, /* The object to make a ByteCode object. */ CompileHookProc *hookProc, /* Procedure to invoke after compilation. */ void *clientData) /* Hook procedure private data. */ { Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ Tcl_Size length; int result = TCL_OK; const char *stringPtr; |
︙ | ︙ | |||
992 993 994 995 996 997 998 | * delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep( | | | 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 | * delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep( Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { ByteCode *codePtr; ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); assert(codePtr != NULL); TclReleaseByteCode(codePtr); |
︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 | /* Just dropped to refcount==0. Clean up. */ CleanupByteCode(codePtr); } static void CleanupByteCode( | | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 | /* Just dropped to refcount==0. Clean up. */ CleanupByteCode(codePtr); } static void CleanupByteCode( ByteCode *codePtr) /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; Interp *iPtr = (Interp *) interp; int numLitObjects = codePtr->numLitObjects; int numAuxDataItems = codePtr->numAuxDataItems; Tcl_Obj **objArrayPtr, *objPtr; const AuxData *auxDataPtr; |
︙ | ︙ | |||
1393 1394 1395 1396 1397 1398 1399 | * the cleanup is delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ static void FreeSubstCodeInternalRep( | | | 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 | * the cleanup is delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ static void FreeSubstCodeInternalRep( Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { ByteCode *codePtr; ByteCodeGetInternalRep(objPtr, &substCodeType, codePtr); assert(codePtr != NULL); TclReleaseByteCode(codePtr); |
︙ | ︙ | |||
1444 1445 1446 1447 1448 1449 1450 | *---------------------------------------------------------------------- */ void TclInitCompileEnv( Tcl_Interp *interp, /* The interpreter for which a CompileEnv * structure is initialized. */ | | | 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 | *---------------------------------------------------------------------- */ void TclInitCompileEnv( Tcl_Interp *interp, /* The interpreter for which a CompileEnv * structure is initialized. */ CompileEnv *envPtr,/* Points to the CompileEnv structure to * initialize. */ const char *stringPtr, /* The source string to be compiled. */ size_t numBytes, /* Number of bytes in source string. */ const CmdFrame *invoker, /* Location context invoking the bcc */ int word) /* Index of the word in that context getting * compiled */ { |
︙ | ︙ | |||
2509 2510 2511 2512 2513 2514 2515 | if ((length == 1) && (buffer[0] == ' ') && (tokenPtr->start[1] == '\n')) { if (isLiteral) { int clPos = Tcl_DStringLength(&textBuffer); if (numCL >= maxNumCL) { maxNumCL *= 2; | | | | 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 | if ((length == 1) && (buffer[0] == ' ') && (tokenPtr->start[1] == '\n')) { if (isLiteral) { int clPos = Tcl_DStringLength(&textBuffer); if (numCL >= maxNumCL) { maxNumCL *= 2; clPosition = (Tcl_Size *)Tcl_Realloc(clPosition, maxNumCL * sizeof(Tcl_Size)); } clPosition[numCL] = clPos; numCL ++; } adjust++; } break; |
︙ | ︙ | |||
2645 2646 2647 2648 2649 2650 2651 | */ void TclCompileCmdWord( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for * a command word to compile inline. */ | | | 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 | */ void TclCompileCmdWord( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for * a command word to compile inline. */ size_t count1, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { int count = count1; if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { /* |
︙ | ︙ | |||
2823 2824 2825 2826 2827 2828 2829 | * Prevent circular reference where the bytecode internalrep of * a value contains a literal which is that same value. * If this is allowed to happen, refcount decrements may not * reach zero, and memory may leak. Bugs 467523, 3357771 * * NOTE: [Bugs 3392070, 3389764] We make a copy based completely * on the string value, and do not call Tcl_DuplicateObj() so we | | | 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 | * Prevent circular reference where the bytecode internalrep of * a value contains a literal which is that same value. * If this is allowed to happen, refcount decrements may not * reach zero, and memory may leak. Bugs 467523, 3357771 * * NOTE: [Bugs 3392070, 3389764] We make a copy based completely * on the string value, and do not call Tcl_DuplicateObj() so we * can be sure we do not have any lingering cycles hiding in * the internalrep. */ Tcl_Size numBytes; const char *bytes = TclGetStringFromObj(objPtr, &numBytes); Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); Tcl_IncrRefCount(copyPtr); |
︙ | ︙ | |||
3030 3031 3032 3033 3034 3035 3036 | * variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ Tcl_Size TclFindCompiledLocal( | | | 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 | * variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ Tcl_Size TclFindCompiledLocal( const char *name, /* Points to first character of the name of a * scalar or array variable. If NULL, a * temporary var should be created. */ Tcl_Size nameBytes, /* Number of bytes in the name. */ int create, /* If 1, allocate a local frame entry for the * variable if it is new. */ CompileEnv *envPtr) /* Points to the current compile environment*/ { |
︙ | ︙ | |||
3086 3087 3088 3089 3090 3091 3092 | localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { char *localName = localPtr->name; if ((nameBytes == localPtr->nameLength) && | | | 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 | localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { char *localName = localPtr->name; if ((nameBytes == localPtr->nameLength) && (strncmp(name,localName,nameBytes) == 0)) { return i; } } localPtr = localPtr->nextPtr; } } |
︙ | ︙ | |||
3209 3210 3211 3212 3213 3214 3215 | EnterCmdStartData( CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ Tcl_Size cmdIndex, /* Index of the command whose start data is * being set. */ Tcl_Size srcOffset, /* Offset of first char of the command. */ | | | 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 | EnterCmdStartData( CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ Tcl_Size cmdIndex, /* Index of the command whose start data is * being set. */ Tcl_Size srcOffset, /* Offset of first char of the command. */ Tcl_Size codeOffset) /* Offset of first byte of command code. */ { CmdLocation *cmdLocPtr; if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) { Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); } |
︙ | ︙ | |||
3287 3288 3289 3290 3291 3292 3293 | static void EnterCmdExtentData( CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ Tcl_Size cmdIndex, /* Index of the command whose source and code * length data is being set. */ | | | | 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 | static void EnterCmdExtentData( CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ Tcl_Size cmdIndex, /* Index of the command whose source and code * length data is being set. */ Tcl_Size numSrcBytes, /* Number of command source chars. */ Tcl_Size numCodeBytes) /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) { Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); } |
︙ | ︙ | |||
3771 3772 3773 3774 3775 3776 3777 | * If there is not enough room in the CompileEnv's AuxData array, its size * is doubled. *---------------------------------------------------------------------- */ Tcl_Size TclCreateAuxData( | | | > | | 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 | * If there is not enough room in the CompileEnv's AuxData array, its size * is doubled. *---------------------------------------------------------------------- */ Tcl_Size TclCreateAuxData( void *clientData, /* The compilation auxiliary data to store in * the new aux data record. */ const AuxDataType *typePtr, /* Pointer to the type to attach to this * AuxData */ CompileEnv *envPtr)/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { Tcl_Size index; /* Index for the new AuxData structure. */ AuxData *auxDataPtr; /* Points to the new AuxData structure */ index = envPtr->auxDataArrayNext; if (index >= envPtr->auxDataArrayEnd) { /* * Expand the AuxData array. The currently allocated entries are * stored between elements 0 and (envPtr->auxDataArrayNext - 1) * [inclusive]. |
︙ | ︙ |
Changes to generic/tclCompile.h.
︙ | ︙ | |||
855 856 857 858 859 860 861 | * are used for indexes or for, e.g., the count of objects to push in a "push" * instruction. */ #define MAX_INSTRUCTION_OPERANDS 2 typedef enum InstOperandType { | | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 | * are used for indexes or for, e.g., the count of objects to push in a "push" * instruction. */ #define MAX_INSTRUCTION_OPERANDS 2 typedef enum InstOperandType { OPERAND_NONE, OPERAND_INT1, /* One byte signed integer. */ OPERAND_INT4, /* Four byte signed integer. */ OPERAND_UINT1, /* One byte unsigned integer. */ OPERAND_UINT4, /* Four byte unsigned integer. */ OPERAND_IDX4, /* Four byte signed index (actually an * integer, but displayed differently.) */ OPERAND_LVT1, /* One byte unsigned index into the local |
︙ | ︙ | |||
1837 1838 1839 1840 1841 1842 1843 | tclDTraceDebugLog = fopen(n, "a"); \ } #define TclDTraceDbgMsg(p, m, ...) \ do { \ if (tclDTraceDebugEnabled) { \ int _l, _t = 0; \ | | < < | | | 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 | tclDTraceDebugLog = fopen(n, "a"); \ } #define TclDTraceDbgMsg(p, m, ...) \ do { \ if (tclDTraceDebugEnabled) { \ int _l, _t = 0; \ if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \ fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", \ strrchr(__FILE__, '/')+1, __LINE__, &_l); _t += _l; \ fprintf(tclDTraceDebugLog, " %.*s():%n", \ (_t < 18 ? 18 - _t : 0) + 18, __func__, &_l); _t += _l; \ fprintf(tclDTraceDebugLog, "%*s" p "%n", \ (_t < 40 ? 40 - _t : 0) + 2 * tclDTraceDebugIndent, \ "", &_l); _t += _l; \ fprintf(tclDTraceDebugLog, "%*s" m "\n", \ (_t < 64 ? 64 - _t : 1), "", ##__VA_ARGS__); \ fflush(tclDTraceDebugLog); \ } \ } while (0) |
︙ | ︙ |
Changes to generic/tclConfig.c.
︙ | ︙ | |||
386 387 388 389 390 391 392 | * The package metadata database is freed. * *---------------------------------------------------------------------- */ static void ConfigDictDeleteProc( | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 | * The package metadata database is freed. * *---------------------------------------------------------------------- */ static void ConfigDictDeleteProc( void *clientData, /* Pointer to Tcl_Obj. */ TCL_UNUSED(Tcl_Interp *)) { Tcl_DecrRefCount((Tcl_Obj *)clientData); } /* * Local Variables: |
︙ | ︙ |
Changes to generic/tclDate.h.
︙ | ︙ | |||
99 100 101 102 103 104 105 | LIT_SETUPTIMEZONE, LIT_MCGET, LIT_GETSYSTEMLOCALE, LIT_GETCURRENTLOCALE, LIT_LOCALIZE_FORMAT, LIT__END } ClockLiteral; | | < | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | 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 | LIT_SETUPTIMEZONE, LIT_MCGET, LIT_GETSYSTEMLOCALE, LIT_GETCURRENTLOCALE, LIT_LOCALIZE_FORMAT, LIT__END } ClockLiteral; #define CLOCK_LITERAL_ARRAY(litarr) static const char *const litarr[] = { \ "", \ "%a %b %d %H:%M:%S %Z %Y", \ "system", "current", "C", \ "BCE", "CE", \ "dayOfMonth", "dayOfWeek", "dayOfYear", \ "era", ":GMT", "gregorian", \ "integer value too large to represent", \ "iso8601Week", "iso8601Year", \ "julianDay", "localSeconds", \ "month", \ "seconds", "tzName", "tzOffset", \ "year", \ "::tcl::clock::TZData", \ "::tcl::clock::GetSystemTimeZone", \ "::tcl::clock::SetupTimeZone", \ "::tcl::clock::mcget", \ "::tcl::clock::GetSystemLocale", "::tcl::clock::mclocale", \ "::tcl::clock::LocalizeFormat" \ } /* * Enumeration of the msgcat literals used in [clock] */ typedef enum ClockMsgCtLiteral { MCLIT__NIL, /* placeholder */ MCLIT_MONTHS_FULL, MCLIT_MONTHS_ABBREV, MCLIT_MONTHS_COMB, MCLIT_DAYS_OF_WEEK_FULL, MCLIT_DAYS_OF_WEEK_ABBREV, MCLIT_DAYS_OF_WEEK_COMB, MCLIT_AM, MCLIT_PM, MCLIT_LOCALE_ERAS, MCLIT_BCE, MCLIT_CE, MCLIT_BCE2, MCLIT_CE2, MCLIT_BCE3, MCLIT_CE3, MCLIT_LOCALE_NUMERALS, MCLIT__END } ClockMsgCtLiteral; #define CLOCK_LOCALE_LITERAL_ARRAY(litarr, pref) static const char *const litarr[] = { \ pref "", \ pref "MONTHS_FULL", pref "MONTHS_ABBREV", pref "MONTHS_COMB", \ pref "DAYS_OF_WEEK_FULL", pref "DAYS_OF_WEEK_ABBREV", pref "DAYS_OF_WEEK_COMB", \ pref "AM", pref "PM", \ pref "LOCALE_ERAS", \ pref "BCE", pref "CE", \ pref "b.c.e.", pref "c.e.", \ pref "b.c.", pref "a.d.", \ pref "LOCALE_NUMERALS", \ } /* * Structure containing the fields used in [clock format] and [clock scan] */ enum TclDateFieldsFlags { CLF_CTZ = (1 << 4) |
︙ | ︙ | |||
484 485 486 487 488 489 490 | unsigned fmtTokC; #if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0 ClockFmtScnStorage *nextPtr; ClockFmtScnStorage *prevPtr; #endif size_t fmtMinAlloc; #if 0 | | < | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 | unsigned fmtTokC; #if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0 ClockFmtScnStorage *nextPtr; ClockFmtScnStorage *prevPtr; #endif size_t fmtMinAlloc; #if 0 Tcl_HashEntry hashEntry /* ClockFmtScnStorage is a derivate of Tcl_HashEntry, * stored by offset +sizeof(self) */ #endif }; /* * Clock macros. */ |
︙ | ︙ |
Changes to generic/tclDictObj.c.
︙ | ︙ | |||
146 147 148 149 150 151 152 | FreeDictInternalRep, /* freeIntRepProc */ DupDictInternalRep, /* dupIntRepProc */ UpdateStringOfDict, /* updateStringProc */ SetDictFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; | | | | | | | | | | | | | | 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 | FreeDictInternalRep, /* freeIntRepProc */ DupDictInternalRep, /* dupIntRepProc */ UpdateStringOfDict, /* updateStringProc */ SetDictFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; #define DictSetInternalRep(objPtr, dictRepPtr) \ do { \ Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (dictRepPtr); \ ir.twoPtrValue.ptr2 = NULL; \ Tcl_StoreInternalRep((objPtr), &tclDictType, &ir); \ } while (0) #define DictGetInternalRep(objPtr, dictRepPtr) \ do { \ const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &tclDictType); \ (dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) /* * The type of the specially adapted version of the Tcl_Obj*-containing hash * table defined in the tclObj.c code. This version differs in that it * allocates a bit more space in each hash entry in order to hold the pointers * used to keep the hash entries in a linked list. * * Note that this type of hash table is *only* suitable for direct use in * *this* file. Everything else should use the dict iterator API. */ static const Tcl_HashKeyType chainHashType = { TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_DIRECT_COMPARE, /* allows compare keys by pointers */ TclHashObjKey, TclCompareObjKeys, AllocChainEntry, TclFreeObjEntry }; /* |
︙ | ︙ | |||
1259 1260 1261 1262 1263 1264 1265 | * Removes a reference to the dictionary's internal rep. * *---------------------------------------------------------------------- */ void Tcl_DictObjDone( | | | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 | * Removes a reference to the dictionary's internal rep. * *---------------------------------------------------------------------- */ void Tcl_DictObjDone( Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; if (searchPtr->epoch) { searchPtr->epoch = 0; dict = (Dict *) searchPtr->dictionaryPtr; if (dict->refCount-- <= 1) { |
︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 | if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList"); } if (keyc < 1) { Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList"); } | | | 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 | if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList"); } if (keyc < 1) { Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList"); } dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE); if (dictPtr == NULL) { return TCL_ERROR; } DictGetInternalRep(dictPtr, dict); assert(dict != NULL); hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); |
︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 | if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList"); } if (keyc < 1) { Tcl_Panic("%s called with empty key list", "Tcl_DictObjRemoveKeyList"); } | | | 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 | if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList"); } if (keyc < 1) { Tcl_Panic("%s called with empty key list", "Tcl_DictObjRemoveKeyList"); } dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE); if (dictPtr == NULL) { return TCL_ERROR; } DictGetInternalRep(dictPtr, dict); assert(dict != NULL); DeleteChainEntry(dict, keyv[keyc-1]); |
︙ | ︙ | |||
1607 1608 1609 1610 1611 1612 1613 | * Loop through the list of keys, looking up the key at the current index * in the current dictionary each time. Once we've done the lookup, we set * the current dictionary to be the value we looked up (in case the value * was not the last one and we are going through a chain of searches.) * Note that this loop always executes at least once. */ | | | 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 | * Loop through the list of keys, looking up the key at the current index * in the current dictionary each time. Once we've done the lookup, we set * the current dictionary to be the value we looked up (in case the value * was not the last one and we are going through a chain of searches.) * Note that this loop always executes at least once. */ dictPtr = TclTraceDictPath(interp, objv[1], objc-3,objv+2, DICT_PATH_READ); if (dictPtr == NULL) { return TCL_ERROR; } result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr); if (result != TCL_OK) { return result; } |
︙ | ︙ | |||
2000 2001 2002 2003 2004 2005 2006 | if (objc == 3) { pattern = TclGetString(objv[2]); } else { pattern = NULL; } listPtr = Tcl_NewListObj(0, NULL); for (; !done ; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) { | | | 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 | if (objc == 3) { pattern = TclGetString(objv[2]); } else { pattern = NULL; } listPtr = Tcl_NewListObj(0, NULL); for (; !done ; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) { if (pattern==NULL || Tcl_StringMatch(TclGetString(valuePtr),pattern)) { /* * Assume this operation always succeeds. */ Tcl_ListObjAppendElement(interp, listPtr, valuePtr); } } |
︙ | ︙ | |||
2139 2140 2141 2142 2143 2144 2145 | Tcl_Obj *dictPtr, *valuePtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?"); return TCL_ERROR; } | | | 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 | Tcl_Obj *dictPtr, *valuePtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?"); return TCL_ERROR; } dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2,DICT_PATH_EXISTS); if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT || Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); } return TCL_OK; |
︙ | ︙ | |||
2802 2803 2804 2805 2806 2807 2808 | } TclDecrRefCount(valueObj); /* * Run the script. */ | | | 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 | } TclDecrRefCount(valueObj); /* * Run the script. */ TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, iPtr->cmdFramePtr, 3); /* * For unwinding everything on error. */ |
︙ | ︙ | |||
2892 2893 2894 2895 2896 2897 2898 | } TclDecrRefCount(valueObj); /* * Run the script. */ | | | 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 | } TclDecrRefCount(valueObj); /* * Run the script. */ TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, iPtr->cmdFramePtr, 3); /* * For unwinding everything once the iterating is done. */ |
︙ | ︙ | |||
3073 3074 3075 3076 3077 3078 3079 | const char *pattern; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType", | | | 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 | const char *pattern; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case FILTER_KEYS: /* * Create a dictionary whose keys all match a certain pattern. |
︙ | ︙ | |||
3382 3383 3384 3385 3386 3387 3388 | * Execute the body after setting up the NRE handler to process the * results. */ objPtr = Tcl_NewListObj(objc-3, objv+2); Tcl_IncrRefCount(objPtr); Tcl_IncrRefCount(objv[1]); | | | 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 | * Execute the body after setting up the NRE handler to process the * results. */ objPtr = Tcl_NewListObj(objc-3, objv+2); Tcl_IncrRefCount(objPtr); Tcl_IncrRefCount(objv[1]); TclNRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL,NULL); return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1); } static int FinalizeDictUpdate( void *data[], |
︙ | ︙ |
Changes to generic/tclDisassemble.c.
︙ | ︙ | |||
553 554 555 556 557 558 559 | AuxData *auxPtr = NULL; suffixBuffer[0] = '\0'; Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: | | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | 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 | AuxData *auxPtr = NULL; suffixBuffer[0] = '\0'; Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; if (opCode == INST_START_CMD) { snprintf(suffixBuffer+strlen(suffixBuffer), sizeof(suffixBuffer) - strlen(suffixBuffer), ", %u cmds start here", opnd); } Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_OFFSET1: opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; snprintf(suffixBuffer, sizeof(suffixBuffer), "pc %u", pcOffset+opnd); Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_OFFSET4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opCode == INST_START_CMD) { snprintf(suffixBuffer, sizeof(suffixBuffer), "next cmd at pc %u", pcOffset+opnd); } else { snprintf(suffixBuffer, sizeof(suffixBuffer), "pc %u", pcOffset+opnd); } Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_LIT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; suffixObj = codePtr->objArrayPtr[opnd]; Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_LIT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; suffixObj = codePtr->objArrayPtr[opnd]; Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_AUX4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); auxPtr = &codePtr->auxDataArrayPtr[opnd]; break; case OPERAND_IDX4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opnd >= -1) { Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); } else if (opnd == -2) { Tcl_AppendPrintfToObj(bufferObj, "end "); } else { Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); } break; case OPERAND_LVT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; goto printLVTindex; case OPERAND_LVT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; printLVTindex: if (localPtr != NULL) { if (opnd >= localCt) { Tcl_Panic("FormatInstruction: bad local var index %u (%" TCL_SIZE_MODIFIER "d locals)", opnd, localCt); } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } if (TclIsVarTemporary(localPtr)) { snprintf(suffixBuffer, sizeof(suffixBuffer), "temp var %u", opnd); } else { snprintf(suffixBuffer, sizeof(suffixBuffer), "var "); suffixSrc = localPtr->name; } } Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", opnd); break; case OPERAND_SCLS1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; Tcl_AppendPrintfToObj(bufferObj, "%s ", tclStringClassTable[opnd].name); break; case OPERAND_NONE: default: break; } |
︙ | ︙ | |||
715 716 717 718 719 720 721 | case INST_LNOT: case INST_BITNOT: case INST_UMINUS: case INST_UPLUS: case INST_TRY_CVT_TO_NUMERIC: case INST_EXPAND_STKTOP: case INST_EXPR_STK: | | | | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 | case INST_LNOT: case INST_BITNOT: case INST_UMINUS: case INST_UPLUS: case INST_TRY_CVT_TO_NUMERIC: case INST_EXPAND_STKTOP: case INST_EXPR_STK: objc = 1; break; case INST_LIST_IN: case INST_LIST_NOT_IN: /* Basic list containment operators. */ case INST_STR_EQ: case INST_STR_NEQ: /* String (in)equality check */ case INST_STR_CMP: /* String compare. */ case INST_STR_INDEX: |
︙ | ︙ | |||
743 744 745 746 747 748 749 | case INST_BITXOR: case INST_BITAND: case INST_EXPON: case INST_ADD: case INST_SUB: case INST_DIV: case INST_MULT: | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | case INST_BITXOR: case INST_BITAND: case INST_EXPON: case INST_ADD: case INST_SUB: case INST_DIV: case INST_MULT: objc = 2; break; case INST_RETURN_STK: /* early pop. TODO: dig out opt dict too :/ */ objc = 1; break; case INST_SYNTAX: case INST_RETURN_IMM: objc = 2; break; case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); break; case INST_INVOKE_STK1: objc = TclGetUInt1AtPtr(pc+1); break; } result = iPtr->innerContext; if (Tcl_IsShared(result)) { Tcl_DecrRefCount(result); iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); Tcl_IncrRefCount(result); } else { Tcl_Size len; /* * Reset while keeping the list internalrep as much as possible. */ TclListObjLength(interp, result, &len); Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); } Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); for (; objc>0 ; objc--) { Tcl_Obj *objPtr; objPtr = tosPtr[1 - objc]; if (!objPtr) { Tcl_Panic("InnerContext: bad tos -- appending null object"); } if ((objPtr->refCount <= 0) #ifdef TCL_MEM_DEBUG || (objPtr->refCount == 0x61616161) #endif ) { Tcl_Panic("InnerContext: bad tos -- appending freed object %p", objPtr); } Tcl_ListObjAppendElement(NULL, result, objPtr); } return result; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
840 841 842 843 844 845 846 | *---------------------------------------------------------------------- */ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { | | | | 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 | *---------------------------------------------------------------------- */ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { size_t inst; /* NOTE: We know this is really an unsigned char */ char *dst; InstNameGetInternalRep(objPtr, inst); if (inst >= LAST_INST_OPCODE) { dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); TclOOM(dst, TCL_INTEGER_SPACE + 5); snprintf(dst, TCL_INTEGER_SPACE + 5, "inst_%" TCL_Z_MODIFIER "u", inst); (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } else { const char *s = tclInstructionTable[inst].name; size_t len = strlen(s); dst = Tcl_InitStringRep(objPtr, s, len); TclOOM(dst, len); } |
︙ | ︙ | |||
1183 1184 1185 1186 1187 1188 1189 | * The way these are encoded in the bytecode is non-trivial; the Decode * macro (which updates its argument and returns the next decoded value) * handles this so that the rest of the code does not. */ #define Decode(ptr) \ ((TclGetUInt1AtPtr(ptr) == 0xFF) \ | | | | 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 | * The way these are encoded in the bytecode is non-trivial; the Decode * macro (which updates its argument and returns the next decoded value) * handles this so that the rest of the code does not. */ #define Decode(ptr) \ ((TclGetUInt1AtPtr(ptr) == 0xFF) \ ? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4)) \ : ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1))) TclNewObj(commands); codeOffPtr = codePtr->codeDeltaStart; codeLenPtr = codePtr->codeLengthStart; srcOffPtr = codePtr->srcDeltaStart; srcLenPtr = codePtr->srcLengthStart; codeOffset = sourceOffset = 0; |
︙ | ︙ | |||
1280 1281 1282 1283 1284 1285 1286 | * in order to disassemble them. * *---------------------------------------------------------------------- */ int Tcl_DisassembleObjCmd( | | | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 | * in order to disassemble them. * *---------------------------------------------------------------------- */ int Tcl_DisassembleObjCmd( void *clientData, /* What type of operation. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const types[] = { "constructor", "destructor", "lambda", "method", "objmethod", "proc", "script", NULL |
︙ | ︙ |
Changes to generic/tclEncoding.c.
︙ | ︙ | |||
30 31 32 33 34 35 36 | * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ void *clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ Tcl_Size nullSize; /* Number of 0x00 bytes that signify * end-of-string in this encoding. This number * is used to determine the source string * length when the srcLen argument is * negative. This number can be 1, 2, or 4. */ LengthProc *lengthProc; /* Function to compute length of * null-terminated strings in this encoding. * If nullSize is 1, this is strlen; if |
︙ | ︙ | |||
197 198 199 200 201 202 203 | int value; } encodingProfiles[] = { {"replace", TCL_ENCODING_PROFILE_REPLACE}, {"strict", TCL_ENCODING_PROFILE_STRICT}, {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; | | | | | | | | | | | 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 | int value; } encodingProfiles[] = { {"replace", TCL_ENCODING_PROFILE_REPLACE}, {"strict", TCL_ENCODING_PROFILE_STRICT}, {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; #define PROFILE_TCL8(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8) #define PROFILE_REPLACE(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) #define PROFILE_STRICT(flags_) \ (!PROFILE_TCL8(flags_) && !PROFILE_REPLACE(flags_)) #define UNICODE_REPLACE_CHAR 0xFFFD #define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) #define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800) #define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00) /* * The following variable is used in the sparse matrix code for a * TableEncoding to represent a page in the table that has no entries. */ static unsigned short emptyPage[256]; |
︙ | ︙ | |||
920 921 922 923 924 925 926 | /* *------------------------------------------------------------------------- * * Tcl_GetEncodingNulLength -- * * Given an encoding, return the number of nul bytes used for the | | | 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 | /* *------------------------------------------------------------------------- * * Tcl_GetEncodingNulLength -- * * Given an encoding, return the number of nul bytes used for the * string termination. * * Results: * The number of nul bytes used for the string termination. * * Side effects: * None. * |
︙ | ︙ | |||
1120 1121 1122 1123 1124 1125 1126 | * "flags" controls the behavior if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: * target encoding. It should be composed by OR-ing the following: * - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT} * * Results: | | < | | | | | | | | | | | | | | | | | | | | 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 | * "flags" controls the behavior if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: * target encoding. It should be composed by OR-ing the following: * - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT} * * Results: * The return value is one of * TCL_OK: success. Converted string in *dstPtr * TCL_ERROR: error in passed parameters. Error message in interp * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition * TCL_CONVERT_UNKNOWN: source contained a character that could not * be represented in target encoding. * * Side effects: * * TCL_OK: The converted bytes are stored in the DString and NUL * terminated in an encoding-specific manner. * TCL_ERROR: an error, message is stored in the interp if not NULL. * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored * in the interpreter (if not NULL). If errorLocPtr is not NULL, * no error message is stored as it is expected the caller is * interested in whatever is decoded so far and not treating this * as an error condition. * * In addition, *dstPtr is always initialized and must be cleared * by the caller irrespective of the return code. * *------------------------------------------------------------------------- */ int Tcl_ExternalToUtfDStringEx( Tcl_Interp *interp, /* For error messages. May be NULL. */ Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ int flags, /* Conversion control flags. */ Tcl_DString *dstPtr, /* Uninitialized or free DString in which the * converted string is stored. */ Tcl_Size *errorLocPtr) /* Where to store the error location * (or TCL_INDEX_NONE if no error). May * be NULL. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; int result; Tcl_Size dstLen, soFar; |
︙ | ︙ | |||
1438 1439 1440 1441 1442 1443 1444 | * Convert a source buffer from UTF-8 to the specified encoding. * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in the * target encoding. It should be composed by OR-ing the following: * - *At most one* of TCL_ENCODING_PROFILE_* * * Results: | | < | | | | | | | | | | | | | | | | | | | | 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 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 | * Convert a source buffer from UTF-8 to the specified encoding. * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in the * target encoding. It should be composed by OR-ing the following: * - *At most one* of TCL_ENCODING_PROFILE_* * * Results: * The return value is one of * TCL_OK: success. Converted string in *dstPtr * TCL_ERROR: error in passed parameters. Error message in interp * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition * TCL_CONVERT_UNKNOWN: source contained a character that could not * be represented in target encoding. * * Side effects: * * TCL_OK: The converted bytes are stored in the DString and NUL * terminated in an encoding-specific manner * TCL_ERROR: an error, message is stored in the interp if not NULL. * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored * in the interpreter (if not NULL). If errorLocPtr is not NULL, * no error message is stored as it is expected the caller is * interested in whatever is decoded so far and not treating this * as an error condition. * * In addition, *dstPtr is always initialized and must be cleared * by the caller irrespective of the return code. * *------------------------------------------------------------------------- */ int Tcl_UtfToExternalDStringEx( Tcl_Interp *interp, /* For error messages. May be NULL. */ Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ int flags, /* Conversion control flags. */ Tcl_DString *dstPtr, /* Uninitialized or free DString in which the * converted string is stored. */ Tcl_Size *errorLocPtr) /* Where to store the error location * (or TCL_INDEX_NONE if no error). May * be NULL. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; int result; const char *srcStart = src; |
︙ | ︙ | |||
2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 | dstStart = dst; flags |= PTR2INT(clientData); dstEnd = dst + dstLen - ((flags & ENCODING_UTF) ? TCL_UTF_MAX : 6); profile = ENCODING_PROFILE_GET(flags); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the * last UTF-8 character in the source buffer hasn't been cut off. */ result = TCL_CONVERT_MULTIBYTE; break; } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } | > < | | 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 | dstStart = dst; flags |= PTR2INT(clientData); dstEnd = dst + dstLen - ((flags & ENCODING_UTF) ? TCL_UTF_MAX : 6); profile = ENCODING_PROFILE_GET(flags); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the * last UTF-8 character in the source buffer hasn't been cut off. */ result = TCL_CONVERT_MULTIBYTE; break; } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) { /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to \xC0\x80. */ *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) && (UCHAR(src[1]) == 0x80) && |
︙ | ︙ | |||
2510 2511 2512 2513 2514 2515 2516 | * the user has explicitly asked to be told. */ if (flags & ENCODING_INPUT) { /* Incomplete bytes for modified UTF-8 target */ if (PROFILE_STRICT(profile)) { result = (flags & TCL_ENCODING_CHAR_LIMIT) | | | | < | < | < | < < | 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 | * the user has explicitly asked to be told. */ if (flags & ENCODING_INPUT) { /* Incomplete bytes for modified UTF-8 target */ if (PROFILE_STRICT(profile)) { result = (flags & TCL_ENCODING_CHAR_LIMIT) ? TCL_CONVERT_MULTIBYTE : TCL_CONVERT_SYNTAX; break; } } if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; ++src; } else { /* TCL_ENCODING_PROFILE_TCL8 */ char chbuf[2]; chbuf[0] = UCHAR(*src++); chbuf[1] = 0; TclUtfToUniChar(chbuf, &ch); } dst += Tcl_UniCharToUtf(ch, dst); } else { size_t len = TclUtfToUniChar(src, &ch); if (flags & ENCODING_INPUT) { if (((len < 2) && (ch != 0)) || ((ch > 0xFFFF) && !(flags & ENCODING_UTF))) { if (PROFILE_STRICT(profile)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; } } } const char *saveSrc = src; src += len; if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT) && (ch > 0x3FF)) { if (ch > 0xFFFF) { /* CESU-8 6-byte sequence for chars > U+FFFF */ ch -= 0x10000; *dst++ = 0xED; *dst++ = (char) (((ch >> 16) & 0x0F) | 0xA0); *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80); ch = (ch & 0x0CFF) | 0xDC00; } *dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF); *dst++ = (char)(((ch >> 6) | 0x80) & 0xBF); *dst++ = (char)((ch | 0x80) & 0xBF); continue; } else if (SURROGATE(ch)) { if (PROFILE_STRICT(profile)) { result = (flags & ENCODING_INPUT) ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; src = saveSrc; break; } else if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; } } dst += Tcl_UniCharToUtf(ch, dst); |
︙ | ︙ | |||
2595 2596 2597 2598 2599 2600 2601 | * None. * *------------------------------------------------------------------------- */ static int Utf32ToUtfProc( | | | 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 | * None. * *------------------------------------------------------------------------- */ static int Utf32ToUtfProc( void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
2724 2725 2726 2727 2728 2729 2730 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf32Proc( | | | 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf32Proc( void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
2823 2824 2825 2826 2827 2828 2829 | * None. * *------------------------------------------------------------------------- */ static int Utf16ToUtfProc( | | | 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 | * None. * *------------------------------------------------------------------------- */ static int Utf16ToUtfProc( void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
2896 2897 2898 2899 2900 2901 2902 | ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); } if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; | | | | < | 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 | ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); } if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; src -= 2; /* Go back to beginning of high surrogate */ dst--; /* Also undo writing a single byte too much */ numChars--; break; } else if (PROFILE_REPLACE(flags)) { /* * Previous loop wrote a single byte to mark the high surrogate. * Replace it with the replacement character. Further, restart * current loop iteration since need to recheck destination space * and reset processing of current character. */ ch = UNICODE_REPLACE_CHAR; dst--; dst += Tcl_UniCharToUtf(ch, dst); src -= 2; numChars--; continue; } else { /* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */ dst += Tcl_UniCharToUtf(-1, dst); } } /* * Special case for 1-byte utf chars for speed. Make sure we work with * unsigned short-size data. |
︙ | ︙ | |||
3002 3003 3004 3005 3006 3007 3008 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf16Proc( | | | 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf16Proc( void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
3110 3111 3112 3113 3114 3115 3116 | * None. * *------------------------------------------------------------------------- */ static int UtfToUcs2Proc( | | | 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 | * None. * *------------------------------------------------------------------------- */ static int UtfToUcs2Proc( void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
3214 3215 3216 3217 3218 3219 3220 | * None. * *------------------------------------------------------------------------- */ static int TableToUtfProc( | | | 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 | * None. * *------------------------------------------------------------------------- */ static int TableToUtfProc( void *clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ |
︙ | ︙ | |||
3299 3300 3301 3302 3303 3304 3305 | if (prefixBytes[byte]) { src--; } if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else { char chbuf[2]; | | < | 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 | if (prefixBytes[byte]) { src--; } if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else { char chbuf[2]; chbuf[0] = byte; chbuf[1] = 0; TclUtfToUniChar(chbuf, &ch); } } /* * Special case for 1-byte Utf chars for speed. */ |
︙ | ︙ | |||
3343 3344 3345 3346 3347 3348 3349 | * None. * *------------------------------------------------------------------------- */ static int TableFromUtfProc( | | | 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 | * None. * *------------------------------------------------------------------------- */ static int TableFromUtfProc( void *clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ |
︙ | ︙ | |||
3635 3636 3637 3638 3639 3640 3641 | * Memory freed. * *--------------------------------------------------------------------------- */ static void TableFreeProc( | | | 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 | * Memory freed. * *--------------------------------------------------------------------------- */ static void TableFreeProc( void *clientData) /* TableEncodingData that specifies * encoding. */ { TableEncodingData *dataPtr = (TableEncodingData *)clientData; /* * Make sure we aren't freeing twice on shutdown. [Bug 219314] */ |
︙ | ︙ | |||
3670 3671 3672 3673 3674 3675 3676 | * None. * *------------------------------------------------------------------------- */ static int EscapeToUtfProc( | | | 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 | * None. * *------------------------------------------------------------------------- */ static int EscapeToUtfProc( void *clientData, /* EscapeEncodingData that specifies * encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are |
︙ | ︙ | |||
3883 3884 3885 3886 3887 3888 3889 | * None. * *------------------------------------------------------------------------- */ static int EscapeFromUtfProc( | | | 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 | * None. * *------------------------------------------------------------------------- */ static int EscapeFromUtfProc( void *clientData, /* EscapeEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are |
︙ | ︙ | |||
4094 4095 4096 4097 4098 4099 4100 | * Memory is freed. * *--------------------------------------------------------------------------- */ static void EscapeFreeProc( | | | 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 | * Memory is freed. * *--------------------------------------------------------------------------- */ static void EscapeFreeProc( void *clientData) /* EscapeEncodingData that specifies * encoding. */ { EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; EscapeSubTable *subTablePtr; int i; if (dataPtr == NULL) { |
︙ | ︙ |
Changes to generic/tclEnsemble.c.
︙ | ︙ | |||
81 82 83 84 85 86 87 | FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; | | | | | | | | | | | | | | | 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 | FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; #define ECRSetInternalRep(objPtr, ecRepPtr) \ do { \ Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (ecRepPtr); \ ir.twoPtrValue.ptr2 = NULL; \ Tcl_StoreInternalRep((objPtr), &ensembleCmdType, &ir); \ } while (0) #define ECRGetInternalRep(objPtr, ecRepPtr) \ do { \ const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType); \ (ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) /* * The internal rep for caching ensemble subcommand lookups and spelling * corrections. */ typedef struct { Tcl_Size epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ Command *token; /* Reference to the command for which this * structure is a cache of the resolution. */ Tcl_Obj *fix; /* Corrected spelling, if needed. */ Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash * table. */ } EnsembleCmdRep; static inline Tcl_Obj * NewNsObj( Tcl_Namespace *namespacePtr) { Namespace *nsPtr = (Namespace *) namespacePtr; |
︙ | ︙ | |||
524 525 526 527 528 529 530 | * we are not incrementing any reference counts in the objects at * this stage, so the presence of an option multiple times won't * cause any memory leaks. */ for (; objc>0 ; objc-=2,objv+=2) { enum EnsConfigOpts idx; | | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | * we are not incrementing any reference counts in the objects at * this stage, so the presence of an option multiple times won't * cause any memory leaks. */ for (; objc>0 ; objc-=2,objv+=2) { enum EnsConfigOpts idx; if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions, "option", 0, &idx) != TCL_OK) { freeMapAndError: if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } |
︙ | ︙ | |||
2466 2467 2468 2469 2470 2471 2472 | static void ClearTable( EnsembleConfig *ensemblePtr) { Tcl_HashTable *hash = &ensemblePtr->subcommandTable; if (hash->numEntries != 0) { | | | | | | | | | | 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 | static void ClearTable( EnsembleConfig *ensemblePtr) { Tcl_HashTable *hash = &ensemblePtr->subcommandTable; if (hash->numEntries != 0) { Tcl_HashSearch search; Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { Tcl_Obj *prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(prefixObj); hPtr = Tcl_NextHashEntry(&search); } Tcl_Free(ensemblePtr->subcommandArrayPtr); } Tcl_DeleteHashTable(hash); } static void DeleteEnsembleConfig( void *clientData) |
︙ | ︙ | |||
2577 2578 2579 2580 2581 2582 2583 | Tcl_Obj *mapDict = ensemblePtr->subcommandDict; Tcl_Obj *subList = ensemblePtr->subcmdList; ClearTable(ensemblePtr); Tcl_InitHashTable(hash, TCL_STRING_KEYS); if (subList) { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 | Tcl_Obj *mapDict = ensemblePtr->subcommandDict; Tcl_Obj *subList = ensemblePtr->subcmdList; ClearTable(ensemblePtr); Tcl_InitHashTable(hash, TCL_STRING_KEYS); if (subList) { Tcl_Size subc; Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; const char *name; /* * There is a list of exactly what subcommands go in the table. * Determine the target for each. */ TclListObjGetElements(NULL, subList, &subc, &subv); if (subList == mapDict) { /* * Unusual case where explicit list of subcommands is same value * as the dict mapping to targets. */ for (i = 0; i < subc; i += 2) { name = TclGetString(subv[i]); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); if (!isNew) { cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(cmdObj); } Tcl_SetHashValue(hPtr, subv[i+1]); Tcl_IncrRefCount(subv[i+1]); name = TclGetString(subv[i+1]); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); if (isNew) { cmdObj = Tcl_NewStringObj(name, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } } } else { /* * Usual case where we can freely act on the list and dict. */ for (i = 0; i < subc; i++) { name = TclGetString(subv[i]); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); if (!isNew) { continue; } /* * Lookup target in the dictionary. */ if (mapDict) { Tcl_DictObjGet(NULL, mapDict, subv[i], &target); if (target) { Tcl_SetHashValue(hPtr, target); Tcl_IncrRefCount(target); continue; } } /* * Target was not in the dictionary. Map onto the namespace. * In this case there is no guarantee that the command * is actually there. It is the responsibility of the * programmer (or [::unknown] of course) to provide the procedure. */ cmdObj = Tcl_NewStringObj(name, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } } } else if (mapDict) { /* * No subcmd list, but there is a mapping dictionary, so * use the keys of that. Convert the contents of the dictionary into the * form required for the internal hashtable of the ensemble. */ Tcl_DictSearch dictSearch; Tcl_Obj *keyObj, *valueObj; int done; Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, &keyObj, &valueObj, &done); while (!done) { const char *name = TclGetString(keyObj); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); Tcl_SetHashValue(hPtr, valueObj); Tcl_IncrRefCount(valueObj); Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); } } else { /* * Use the array of patterns and the hash table whose keys are the * commands exported by the namespace. The corresponding values do not * matter here. Filter the commands in the namespace against the * patterns in the export list to find out what commands are actually * exported. Use an intermediate hash table to make memory management |
︙ | ︙ | |||
2993 2994 2995 2996 2997 2998 2999 | for (i=0 ; i<len ; i++) { str = TclGetStringFromObj(elems[i], &sclen); if ((sclen == numBytes) && !memcmp(word, str, numBytes)) { /* * Exact match! Excellent! */ | | | 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 | for (i=0 ; i<len ; i++) { str = TclGetStringFromObj(elems[i], &sclen); if ((sclen == numBytes) && !memcmp(word, str, numBytes)) { /* * Exact match! Excellent! */ result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj); if (result != TCL_OK || targetCmdObj == NULL) { goto tryCompileToInv; } replacement = elems[i]; goto doneMapLookup; } |
︙ | ︙ | |||
3175 3176 3177 3178 3179 3180 3181 | } /* * Throw out any line information generated by the failed compile attempt. */ while (mapPtr->nuloc > eclIndex + 1) { | | | | | 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 | } /* * Throw out any line information generated by the failed compile attempt. */ while (mapPtr->nuloc > eclIndex + 1) { mapPtr->nuloc--; Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; } /* * Reset the index of next command. Toss out any from failed nested * partial compiles. */ |
︙ | ︙ | |||
3433 3434 3435 3436 3437 3438 3439 | TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); /* * Do the replacing dispatch. */ | | | 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 | TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); /* * Do the replacing dispatch. */ TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1); } /* * Helpers that do issuing of instructions for commands that "don't have * compilers" (well, they do; these). They all work by just generating base * code to invoke the command; they're intended for ensemble subcommands so * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out |
︙ | ︙ |
Changes to generic/tclEnv.c.
︙ | ︙ | |||
15 16 17 18 19 20 21 | #include "tclInt.h" TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */ #if defined(_WIN32) # define tenviron _wenviron | | < | < | < | | | | 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 49 50 51 52 53 54 55 | #include "tclInt.h" TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */ #if defined(_WIN32) # define tenviron _wenviron # define tenviron2utfdstr(str, dsPtr) (Tcl_DStringInit(dsPtr), \ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(str), -1, (dsPtr))) # define utf2tenvirondstr(str, dsPtr) (Tcl_DStringInit(dsPtr), \ (const WCHAR *)Tcl_UtfToChar16DString((str), -1, (dsPtr))) # define techar WCHAR # ifdef USE_PUTENV # define putenv(env) _wputenv((const wchar_t *)env) # endif #else # define tenviron environ # define tenviron2utfdstr(str, dsPtr) \ Tcl_ExternalToUtfDString(NULL, str, -1, dsPtr) # define utf2tenvirondstr(str, dsPtr) \ Tcl_UtfToExternalDString(NULL, str, -1, dsPtr) # define techar char #endif /* MODULE_SCOPE */ size_t TclEnvEpoch = 0; /* Epoch of the tcl environment * (if changed with tcl-env). */ static struct { Tcl_Size cacheSize; /* Number of env strings in cache. */ char **cache; /* Array containing all of the environment * strings that Tcl has allocated. */ #ifndef USE_PUTENV techar **ourEnviron; /* Cache of the array that we allocate. We * need to track this in case another * subsystem swaps around the environ array * like we do. */ Tcl_Size ourEnvironSize; /* Non-zero means that the environ array was * malloced and has this many total entries * allocated to it (not all may be in use at * once). Zero means that the environment |
︙ | ︙ |
Changes to generic/tclEvent.c.
︙ | ︙ | |||
65 66 67 68 69 70 71 | /* * For each exit handler created with a call to Tcl_Create(Late)ExitHandler * there is a structure of the following type: */ typedef struct ExitHandler { Tcl_ExitProc *proc; /* Function to call when process exits. */ | | | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | /* * For each exit handler created with a call to Tcl_Create(Late)ExitHandler * there is a structure of the following type: */ typedef struct ExitHandler { Tcl_ExitProc *proc; /* Function to call when process exits. */ void *clientData; /* One word of information to pass to proc. */ struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this * application, or NULL for end of list. */ } ExitHandler; /* * There is both per-process and per-thread exit handlers. The first list is * controlled by a mutex. The other is in thread local storage. |
︙ | ︙ | |||
115 116 117 118 119 120 121 | * standard channels. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #if TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | * standard channels. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #if TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ void *clientData; /* The one argument to Main() */ } ThreadClientData; static Tcl_ThreadCreateType NewThreadProc(void *clientData); #endif /* TCL_THREADS */ /* * Prototypes for functions referenced only in this file: */ |
︙ | ︙ | |||
205 206 207 208 209 210 211 | * Depends on what actions the handler command takes for the errors. * *---------------------------------------------------------------------- */ static void HandleBgErrors( | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 | * Depends on what actions the handler command takes for the errors. * *---------------------------------------------------------------------- */ static void HandleBgErrors( void *clientData) /* Pointer to ErrAssocData structure. */ { ErrAssocData *assocPtr = (ErrAssocData *)clientData; Tcl_Interp *interp = assocPtr->interp; BgError *errPtr; /* * Not bothering to save/restore the interp state. Assume that any code |
︙ | ︙ | |||
607 608 609 610 611 612 613 | * reports, they are canceled. * *---------------------------------------------------------------------- */ static void BgErrorDeleteProc( | | | 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 | * reports, they are canceled. * *---------------------------------------------------------------------- */ static void BgErrorDeleteProc( void *clientData, /* Pointer to ErrAssocData structure. */ TCL_UNUSED(Tcl_Interp *)) { ErrAssocData *assocPtr = (ErrAssocData *)clientData; BgError *errPtr; while (assocPtr->firstBgPtr != NULL) { errPtr = assocPtr->firstBgPtr; |
︙ | ︙ | |||
646 647 648 649 650 651 652 | * *---------------------------------------------------------------------- */ void Tcl_CreateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ | | | 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 | * *---------------------------------------------------------------------- */ void Tcl_CreateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; Tcl_MutexLock(&exitMutex); exitPtr->nextPtr = firstExitPtr; |
︙ | ︙ | |||
679 680 681 682 683 684 685 | * *---------------------------------------------------------------------- */ void TclCreateLateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ | | | 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 | * *---------------------------------------------------------------------- */ void TclCreateLateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; Tcl_MutexLock(&exitMutex); exitPtr->nextPtr = firstLateExitPtr; |
︙ | ︙ | |||
712 713 714 715 716 717 718 | * *---------------------------------------------------------------------- */ void Tcl_DeleteExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ | | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 | * *---------------------------------------------------------------------- */ void Tcl_DeleteExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; Tcl_MutexLock(&exitMutex); for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { if ((exitPtr->proc == proc) |
︙ | ︙ | |||
755 756 757 758 759 760 761 | * *---------------------------------------------------------------------- */ void TclDeleteLateExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ | | | 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 | * *---------------------------------------------------------------------- */ void TclDeleteLateExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; Tcl_MutexLock(&exitMutex); for (prevPtr = NULL, exitPtr = firstLateExitPtr; exitPtr != NULL; prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { if ((exitPtr->proc == proc) |
︙ | ︙ | |||
798 799 800 801 802 803 804 | * *---------------------------------------------------------------------- */ void Tcl_CreateThreadExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ | | | 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 | * *---------------------------------------------------------------------- */ void Tcl_CreateThreadExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; |
︙ | ︙ | |||
831 832 833 834 835 836 837 | * *---------------------------------------------------------------------- */ void Tcl_DeleteThreadExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ | | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 | * *---------------------------------------------------------------------- */ void Tcl_DeleteThreadExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { if ((exitPtr->proc == proc) |
︙ | ︙ | |||
893 894 895 896 897 898 899 | } /* *---------------------------------------------------------------------- * * InvokeExitHandlers -- * | | | | | 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 | } /* *---------------------------------------------------------------------- * * InvokeExitHandlers -- * * Call the registered exit handlers. * * Results: * None. * * Side effects: * The exit handlers are invoked, and the ExitHandler struct is * freed. * *---------------------------------------------------------------------- */ static void InvokeExitHandlers(void) { ExitHandler *exitPtr; |
︙ | ︙ | |||
1126 1127 1128 1129 1130 1131 1132 | /* * Double check inside the mutex. There are definitely calls back into * this routine from some of the functions below. */ TclpInitLock(); if (subsystemsInitialized == 0) { | > | | | 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 | /* * Double check inside the mutex. There are definitely calls back into * this routine from some of the functions below. */ TclpInitLock(); if (subsystemsInitialized == 0) { /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ TclInitThreadStorage(); /* Creates hash table for * thread local storage */ #if defined(USE_TCLALLOC) && USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif #if TCL_THREADS && defined(USE_THREAD_ALLOC) TclInitThreadAlloc(); /* Setup thread allocator caches */ #endif |
︙ | ︙ | |||
2041 2042 2043 2044 2045 2046 2047 | */ int Tcl_CreateThread( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ void *clientData, /* The one argument to Main() */ | | | 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 | */ int Tcl_CreateThread( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ void *clientData, /* The one argument to Main() */ size_t stackSize, /* Size of stack for the new thread */ int flags) /* Flags controlling behaviour of the new * thread. */ { #if TCL_THREADS ThreadClientData *cdPtr = (ThreadClientData *)Tcl_Alloc(sizeof(ThreadClientData)); int result; |
︙ | ︙ |
Changes to generic/tclFCmd.c.
︙ | ︙ | |||
914 915 916 917 918 919 920 | Tcl_Obj *splitPtr; Tcl_Obj *resultPtr = NULL; splitPtr = Tcl_FSSplitPath(pathPtr, &objc); Tcl_IncrRefCount(splitPtr); if (objc != 0) { | | | | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 | Tcl_Obj *splitPtr; Tcl_Obj *resultPtr = NULL; splitPtr = Tcl_FSSplitPath(pathPtr, &objc); Tcl_IncrRefCount(splitPtr); if (objc != 0) { /* * Return the last component, unless it is the only component, and it * is the root of an absolute path. */ if (objc > 0) { Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr); if ((objc == 1) && (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { |
︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 | int index; Tcl_Obj *objPtr = NULL; if (numObjStrings == 0) { TclPrintfResult(interp, "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0])); | | | 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 | int index; Tcl_Obj *objPtr = NULL; if (numObjStrings == 0) { TclPrintfResult(interp, "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0])); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", (void *)NULL); goto end; } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } |
︙ | ︙ | |||
1135 1136 1137 1138 1139 1140 1141 | int i, index; if (numObjStrings == 0) { TclPrintfResult(interp, "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0])); | | | 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 | int i, index; if (numObjStrings == 0) { TclPrintfResult(interp, "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0])); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", (void *)NULL); goto end; } for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; |
︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 | } /* * Create and open the temporary file. */ makeTemporary: | | | 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 | } /* * Create and open the temporary file. */ makeTemporary: chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj); /* * If we created pieces of template, get rid of them now. */ if (tempDirObj) { TclDecrRefCount(tempDirObj); |
︙ | ︙ |
Changes to generic/tclFileName.c.
︙ | ︙ | |||
344 345 346 347 348 349 350 | */ Tcl_PathType Tcl_GetPathType( const char *path) { Tcl_PathType type; | | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 | */ Tcl_PathType Tcl_GetPathType( const char *path) { Tcl_PathType type; Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1); Tcl_IncrRefCount(tempObj); type = Tcl_FSGetPathType(tempObj); Tcl_DecrRefCount(tempObj); return type; } |
︙ | ︙ | |||
377 378 379 380 381 382 383 | * *---------------------------------------------------------------------- */ Tcl_PathType TclpGetNativePathType( Tcl_Obj *pathPtr, /* Native path of interest */ | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | * *---------------------------------------------------------------------- */ Tcl_PathType TclpGetNativePathType( Tcl_Obj *pathPtr, /* Native path of interest */ Tcl_Size *driveNameLengthPtr, /* Returns length of drive, if non-NULL and * path was absolute */ Tcl_Obj **driveNameRef) { Tcl_PathType type = TCL_PATH_ABSOLUTE; const char *path = TclGetString(pathPtr); switch (tclPlatform) { case TCL_PLATFORM_UNIX: { const char *origPath = path; /* * Paths that begin with / are absolute. */ if (path[0] == '/') { ++path; /* * Check for "//" network path prefix */ if ((*path == '/') && path[1] && (path[1] != '/')) { path += 2; while (*path && *path != '/') { ++path; } } if (driveNameLengthPtr != NULL) { /* * We need this addition in case the "//" code was used. */ *driveNameLengthPtr = (path - origPath); } } else { type = TCL_PATH_RELATIVE; } break; } case TCL_PLATFORM_WINDOWS: { Tcl_DString ds; const char *rootEnd; Tcl_DStringInit(&ds); rootEnd = ExtractWinRoot(path, &ds, 0, &type); if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { *driveNameLengthPtr = rootEnd - path; if (driveNameRef != NULL) { *driveNameRef = Tcl_DStringToObj(&ds); Tcl_IncrRefCount(*driveNameRef); } } Tcl_DStringFree(&ds); break; } } return type; } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
651 652 653 654 655 656 657 | for (;;) { elementStart = path; while ((*path != '\0') && (*path != '/')) { path++; } length = path - elementStart; if (length > 0) { | > | | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 | for (;;) { elementStart = path; while ((*path != '\0') && (*path != '/')) { path++; } length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; nextElt = Tcl_NewStringObj(elementStart, length); Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*path++ == '\0') { break; } } return result; } |
︙ | ︙ | |||
976 977 978 979 980 981 982 | * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system * interfaces. * * Results: * The return value is a pointer to a string containing the name. | | | | 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 | * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system * interfaces. * * Results: * The return value is a pointer to a string containing the name. * This may either be the name pointer passed in or space allocated in * bufferPtr. In all cases, if the return value is not NULL, the caller * must call Tcl_DStringFree() to free the space. If there was an * error in processing the name, then an error message is left in the * interp's result (if interp was not NULL) and the return value is NULL. * * Side effects: * None. * |
︙ | ︙ | |||
1128 1129 1130 1131 1132 1133 1134 | "-directory", "-join", "-nocomplain", "-path", "-tails", "-types", "--", NULL }; enum globOptionsEnum { GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, GLOB_TYPE, GLOB_LAST } index; | | | 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 | "-directory", "-join", "-nocomplain", "-path", "-tails", "-types", "--", NULL }; enum globOptionsEnum { GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, GLOB_TYPE, GLOB_LAST } index; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; Tcl_GlobTypeData *globTypes = NULL; globFlags = 0; join = 0; dir = PATH_NONE; typePtr = NULL; for (i = 1; i < objc; i++) { |
︙ | ︙ | |||
1186 1187 1188 1189 1190 1191 1192 | globFlags |= TCL_GLOBMODE_DIR; pathOrDir = objv[i+1]; i++; break; case GLOB_JOIN: /* -join */ join = 1; break; | | | 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 | globFlags |= TCL_GLOBMODE_DIR; pathOrDir = objv[i+1]; i++; break; case GLOB_JOIN: /* -join */ join = 1; break; case GLOB_TAILS: /* -tails */ globFlags |= TCL_GLOBMODE_TAILS; break; case GLOB_PATH: /* -path */ if (i == (objc-1)) { TclSetResult(interp, "missing argument to \"-path\""); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); return TCL_ERROR; |
︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 | separators = "/\\:"; break; } if (dir == PATH_GENERAL) { Tcl_Size pathlength; const char *last; | | | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 | separators = "/\\:"; break; } if (dir == PATH_GENERAL) { Tcl_Size pathlength; const char *last; const char *first = TclGetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path */ last = first + pathlength; for (; last != first; last--) { |
︙ | ︙ | |||
2242 2243 2244 2245 2246 2247 2248 | joinedPtr = Tcl_DuplicateObj(pathPtr); if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) { /* * The current prefix must end in a separator. */ Tcl_Size len; | | | 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 | joinedPtr = Tcl_DuplicateObj(pathPtr); if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) { /* * The current prefix must end in a separator. */ Tcl_Size len; const char *joined = TclGetStringFromObj(joinedPtr,&len); if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { Tcl_AppendToObj(joinedPtr, "/", 1); } } Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append), Tcl_DStringLength(&append)); |
︙ | ︙ | |||
2279 2280 2281 2282 2283 2284 2285 | * volume-relative path. In particular globbing in Windows shares, * when not using -dir or -path, e.g. 'glob [file join * //machine/share/subdir *]' requires adding a separator here. * This behaviour is not currently tested for in the test suite. */ Tcl_Size len; | | | 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 | * volume-relative path. In particular globbing in Windows shares, * when not using -dir or -path, e.g. 'glob [file join * //machine/share/subdir *]' requires adding a separator here. * This behaviour is not currently tested for in the test suite. */ Tcl_Size len; const char *joined = TclGetStringFromObj(joinedPtr,&len); if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { Tcl_AppendToObj(joinedPtr, "/", 1); } } } |
︙ | ︙ |
Changes to generic/tclHash.c.
︙ | ︙ | |||
56 57 58 59 60 61 62 | int *newPtr); static Tcl_HashEntry * CreateHashEntry(Tcl_HashTable *tablePtr, const char *key, int *newPtr); static Tcl_HashEntry * FindHashEntry(Tcl_HashTable *tablePtr, const char *key); static void RebuildTable(Tcl_HashTable *tablePtr); const Tcl_HashKeyType tclArrayHashKeyType = { | | | | | | | | | | | | | | | | | | | | 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 | int *newPtr); static Tcl_HashEntry * CreateHashEntry(Tcl_HashTable *tablePtr, const char *key, int *newPtr); static Tcl_HashEntry * FindHashEntry(Tcl_HashTable *tablePtr, const char *key); static void RebuildTable(Tcl_HashTable *tablePtr); const Tcl_HashKeyType tclArrayHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ TCL_HASH_KEY_RANDOMIZE_HASH, /* flags */ HashArrayKey, /* hashKeyProc */ CompareArrayKeys, /* compareKeysProc */ AllocArrayEntry, /* allocEntryProc */ NULL /* freeEntryProc */ }; const Tcl_HashKeyType tclOneWordHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ NULL, /* HashOneWordKey, */ /* hashProc */ NULL, /* CompareOneWordKey, */ /* compareProc */ NULL, /* AllocOneWordKey, */ /* allocEntryProc */ NULL /* FreeOneWordKey, */ /* freeEntryProc */ }; const Tcl_HashKeyType tclStringHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ HashStringKey, /* hashKeyProc */ CompareStringKeys, /* compareKeysProc */ AllocStringEntry, /* allocEntryProc */ NULL /* freeEntryProc */ }; /* *---------------------------------------------------------------------- * * Tcl_InitHashTable -- * |
︙ | ︙ | |||
102 103 104 105 106 107 108 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitHashTable( | > | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitHashTable( Tcl_HashTable *tablePtr, /* Pointer to table record, which is supplied * by the caller. */ int keyType) /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, or an * integer >= 2. */ { /* * Use a special value to inform the extended version that it must not |
︙ | ︙ | |||
139 140 141 142 143 144 145 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitCustomHashTable( | > | | < | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitCustomHashTable( Tcl_HashTable *tablePtr, /* Pointer to table record, which is supplied * by the caller. */ int keyType, /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * TCL_CUSTOM_TYPE_KEYS, TCL_CUSTOM_PTR_KEYS, * or an integer >= 2. */ const Tcl_HashKeyType *typePtr) /* Pointer to structure which defines the * behaviour of this table. */ { #if (TCL_SMALL_HASH_TABLE != 4) Tcl_Panic("Tcl_InitCustomHashTable: TCL_SMALL_HASH_TABLE is %d, not 4", TCL_SMALL_HASH_TABLE); #endif |
︙ | ︙ | |||
280 281 282 283 284 285 286 | for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { if (hash != hPtr->hash) { continue; } /* if keys pointers or values are equal */ if ((key == hPtr->key.oneWordValue) | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 | for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { if (hash != hPtr->hash) { continue; } /* if keys pointers or values are equal */ if ((key == hPtr->key.oneWordValue) || compareKeysProc((void *) key, hPtr)) { if (newPtr) { *newPtr = 0; } return hPtr; } } } else { /* no direct compare - compare key addresses only */ |
︙ | ︙ | |||
551 552 553 554 555 556 557 | * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_NextHashEntry( | | > | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 | * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_NextHashEntry( Tcl_HashSearch *searchPtr) /* Place to store information about progress * through the table. Must have been * initialized by calling * Tcl_FirstHashEntry. */ { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr = searchPtr->tablePtr; |
︙ | ︙ | |||
665 666 667 668 669 670 671 | * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocArrayEntry( Tcl_HashTable *tablePtr, /* Hash table. */ | | | 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 | * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocArrayEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_HashEntry *hPtr; size_t count = tablePtr->keyType * sizeof(int); size_t size = offsetof(Tcl_HashEntry, key) + count; if (size < sizeof(Tcl_HashEntry)) { size = sizeof(Tcl_HashEntry); |
︙ | ︙ | |||
701 702 703 704 705 706 707 | * None. * *---------------------------------------------------------------------- */ static int CompareArrayKeys( | | | 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 | * None. * *---------------------------------------------------------------------- */ static int CompareArrayKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { size_t count = hPtr->tablePtr->keyType * sizeof(int); return !memcmp(keyPtr, hPtr->key.string, count); } |
︙ | ︙ | |||
730 731 732 733 734 735 736 | * *---------------------------------------------------------------------- */ static size_t HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ | | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 | * *---------------------------------------------------------------------- */ static size_t HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { const int *array = (const int *) keyPtr; size_t result; int count; for (result = 0, count = tablePtr->keyType; count > 0; count--, array++) { |
︙ | ︙ | |||
762 763 764 765 766 767 768 | * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocStringEntry( TCL_UNUSED(Tcl_HashTable *), | | | 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 | * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocStringEntry( TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key to store in the hash table entry. */ { const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; size_t size, allocsize; allocsize = size = strlen(string) + 1; if (size < sizeof(hPtr->key)) { |
︙ | ︙ | |||
798 799 800 801 802 803 804 | * None. * *---------------------------------------------------------------------- */ static int CompareStringKeys( | | | 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 | * None. * *---------------------------------------------------------------------- */ static int CompareStringKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { return !strcmp((char *)keyPtr, hPtr->key.string); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
824 825 826 827 828 829 830 | * *---------------------------------------------------------------------- */ static size_t HashStringKey( TCL_UNUSED(Tcl_HashTable *), | | | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 | * *---------------------------------------------------------------------- */ static size_t HashStringKey( TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key from which to compute hash value. */ { const char *string = (const char *)keyPtr; size_t result; char c; /* * I tried a zillion different hash functions and asked many other people |
︙ | ︙ |
Changes to generic/tclIO.c.
︙ | ︙ | |||
226 227 228 229 230 231 232 | const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); static Tcl_Size Write(Channel *chanPtr, const char *src, Tcl_Size srcLen, Tcl_Encoding encoding); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); | | | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 | const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); static Tcl_Size Write(Channel *chanPtr, const char *src, Tcl_Size srcLen, Tcl_Encoding encoding); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); static int WillRead(Channel *chanPtr); #define WriteChars(chanPtr, src, srcLen) \ Write(chanPtr, src, srcLen, chanPtr->state->encoding) #define WriteBytes(chanPtr, src, srcLen) \ Write(chanPtr, src, srcLen, tclIdentityEncoding) /* * Simplifying helper macros. All may use their argument(s) multiple times. * The ANSI C "prototypes" for the macros are listed below, together with a * short description of what the macro does. * * -------------------------------------------------------------------------- |
︙ | ︙ | |||
309 310 311 312 313 314 315 | * Macro for testing whether a string (in optionName, length len) matches a * value (prefix matching rules). Arguments are the minimum length to match * and the value to match against. (Can't use Tcl_GetIndexFromObj as this is * used in a situation where no objects are available.) */ #define HaveOpt(minLength, nameString) \ | | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | * Macro for testing whether a string (in optionName, length len) matches a * value (prefix matching rules). Arguments are the minimum length to match * and the value to match against. (Can't use Tcl_GetIndexFromObj as this is * used in a situation where no objects are available.) */ #define HaveOpt(minLength, nameString) \ ((len > (minLength)) && (optionName[1] == (nameString)[1]) \ && (strncmp(optionName, (nameString), len) == 0)) /* * The ChannelObjType type. Used to store the result of looking up * a channel name in the context of an interp. Saves the lookup * result and values needed to check its continued validity. */ |
︙ | ︙ | |||
331 332 333 334 335 336 337 | } ResolvedChanName; static void DupChannelInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeChannelInternalRep(Tcl_Obj *objPtr); static const Tcl_ObjType chanObjType = { "channel", /* name for this type */ | | | > > > | | | | | | | | | 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 | } ResolvedChanName; static void DupChannelInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeChannelInternalRep(Tcl_Obj *objPtr); static const Tcl_ObjType chanObjType = { "channel", /* name for this type */ FreeChannelInternalRep, /* freeIntRepProc */ DupChannelInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; #define GetIso88591() \ (binaryEncoding ? Tcl_GetEncoding(NULL, "iso8859-1") : binaryEncoding) #define ChanSetInternalRep(objPtr, resPtr) \ do { \ Tcl_ObjInternalRep ir; \ (resPtr)->refCount++; \ ir.twoPtrValue.ptr1 = (resPtr); \ ir.twoPtrValue.ptr2 = NULL; \ Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \ } while (0) #define ChanGetInternalRep(objPtr, resPtr) \ do { \ const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &chanObjType); \ (resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) #define BUSY_STATE(st, fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) #define MAX_CHANNEL_BUFFER_SIZE (1024*1024) /* *--------------------------------------------------------------------------- * * ChanClose, ChanRead, ChanSeek, ChanThreadAction, ChanWatch, ChanWrite -- |
︙ | ︙ | |||
842 843 844 845 846 847 848 | void Tcl_CreateCloseHandler( Tcl_Channel chan, /* The channel for which to create the close * callback. */ Tcl_CloseProc *proc, /* The callback routine to call when the * channel will be closed. */ | | | 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 | void Tcl_CreateCloseHandler( Tcl_Channel chan, /* The channel for which to create the close * callback. */ Tcl_CloseProc *proc, /* The callback routine to call when the * channel will be closed. */ void *clientData) /* Arbitrary data to pass to the close * callback. */ { ChannelState *statePtr = ((Channel *) chan)->state; CloseCallback *cbPtr; cbPtr = (CloseCallback *)Tcl_Alloc(sizeof(CloseCallback)); cbPtr->proc = proc; |
︙ | ︙ | |||
880 881 882 883 884 885 886 | void Tcl_DeleteCloseHandler( Tcl_Channel chan, /* The channel for which to cancel the close * callback. */ Tcl_CloseProc *proc, /* The procedure for the callback to * remove. */ | | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 | void Tcl_DeleteCloseHandler( Tcl_Channel chan, /* The channel for which to cancel the close * callback. */ Tcl_CloseProc *proc, /* The procedure for the callback to * remove. */ void *clientData) /* The callback data for the callback to * remove. */ { ChannelState *statePtr = ((Channel *) chan)->state; CloseCallback *cbPtr, *cbPrevPtr; for (cbPtr = statePtr->closeCbPtr, cbPrevPtr = NULL; cbPtr != NULL; cbPtr = cbPtr->nextPtr) { |
︙ | ︙ | |||
979 980 981 982 983 984 985 | * registered in this interpreter. * *---------------------------------------------------------------------- */ static void DeleteChannelTable( | | | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 | * registered in this interpreter. * *---------------------------------------------------------------------- */ static void DeleteChannelTable( void *clientData, /* The per-interpreter data structure. */ Tcl_Interp *interp) /* The interpreter being deleted. */ { Tcl_HashTable *hTblPtr; /* The hash table. */ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ Channel *chanPtr; /* Channel being deleted. */ ChannelState *statePtr; /* State of Channel being deleted. */ |
︙ | ︙ | |||
1588 1589 1590 1591 1592 1593 1594 | * Creates a new Tcl_Channel instance and inserts it into the hash table. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_CreateChannel( | | < | | 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 | * Creates a new Tcl_Channel instance and inserts it into the hash table. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_CreateChannel( const Tcl_ChannelType *typePtr, /* The channel type record. */ const char *chanName, /* Name of channel to record. */ void *instanceData, /* Instance specific data. */ int mask) /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ { Channel *chanPtr; /* The channel structure newly created. */ ChannelState *statePtr; /* The stack-level independent state info for * the channel. */ const char *name; |
︙ | ︙ | |||
1801 1802 1803 1804 1805 1806 1807 | Tcl_Channel Tcl_StackChannel( Tcl_Interp *interp, /* The interpreter we are working in */ const Tcl_ChannelType *typePtr, /* The channel type record for the new * channel. */ | | | 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 | Tcl_Channel Tcl_StackChannel( Tcl_Interp *interp, /* The interpreter we are working in */ const Tcl_ChannelType *typePtr, /* The channel type record for the new * channel. */ void *instanceData, /* Instance specific data for the new * channel. */ int mask, /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ Tcl_Channel prevChan) /* The channel structure to replace */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Channel *chanPtr, *prevChanPtr; |
︙ | ︙ | |||
2399 2400 2401 2402 2403 2404 2405 | *---------------------------------------------------------------------- */ int Tcl_GetChannelHandle( Tcl_Channel chan, /* The channel to get file from. */ int direction, /* TCL_WRITABLE or TCL_READABLE. */ | | | 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 | *---------------------------------------------------------------------- */ int Tcl_GetChannelHandle( Tcl_Channel chan, /* The channel to get file from. */ int direction, /* TCL_WRITABLE or TCL_READABLE. */ void **handlePtr) /* Where to store handle */ { Channel *chanPtr; /* The actual channel. */ void *handle; int result; chanPtr = ((Channel *) chan)->state->bottomChanPtr; if (!chanPtr->typePtr->getHandleProc) { |
︙ | ︙ | |||
2439 2440 2441 2442 2443 2444 2445 | * May leave an error message in the interp. * *---------------------------------------------------------------------- */ int Tcl_RemoveChannelMode( | | < | | | 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 | * May leave an error message in the interp. * *---------------------------------------------------------------------- */ int Tcl_RemoveChannelMode( Tcl_Interp *interp, /* The interp for an error message. Allowed to be NULL. */ Tcl_Channel chan, /* The channel which is modified. */ int mode) /* The access mode to drop from the channel */ { const char* emsg; ChannelState *statePtr = ((Channel *) chan)->state; /* State of actual channel. */ if ((mode != TCL_READABLE) && (mode != TCL_WRITABLE)) { emsg = "Illegal mode value."; |
︙ | ︙ | |||
2495 2496 2497 2498 2499 2500 2501 | * None. * *--------------------------------------------------------------------------- */ static ChannelBuffer * AllocChannelBuffer( | | | 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 | * None. * *--------------------------------------------------------------------------- */ static ChannelBuffer * AllocChannelBuffer( Tcl_Size length) /* Desired length of channel buffer. */ { ChannelBuffer *bufPtr; Tcl_Size n; n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING; bufPtr = (ChannelBuffer *)Tcl_Alloc(n); bufPtr->nextAdded = BUFFER_PADDING; |
︙ | ︙ | |||
3416 3417 3418 3419 3420 3421 3422 | * referenced in any interpreter. May be NULL, * in which case this is a no-op. */ { CloseCallback *cbPtr; /* Iterate over close callbacks for this * channel. */ Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of real IO channel. */ | | | 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 | * referenced in any interpreter. May be NULL, * in which case this is a no-op. */ { CloseCallback *cbPtr; /* Iterate over close callbacks for this * channel. */ Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of real IO channel. */ int result = 0; /* Of calling FlushChannel. */ int flushcode; int stickyError; if (chan == NULL) { return TCL_OK; } |
︙ | ︙ | |||
4031 4032 4033 4034 4035 4036 4037 | *---------------------------------------------------------------------- */ Tcl_Size Tcl_Write( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* Data to queue in output buffer. */ | | | | 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 | *---------------------------------------------------------------------- */ Tcl_Size Tcl_Write( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* Data to queue in output buffer. */ Tcl_Size srcLen) /* Length of data in bytes, or TCL_INDEX_NONE for * strlen(). */ { /* * Always use the topmost channel of the stack */ Channel *chanPtr; ChannelState *statePtr; /* State info for channel */ |
︙ | ︙ | |||
4143 4144 4145 4146 4147 4148 4149 | */ Tcl_Size Tcl_WriteChars( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* UTF-8 characters to queue in output * buffer. */ | | | | 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 | */ Tcl_Size Tcl_WriteChars( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* UTF-8 characters to queue in output * buffer. */ Tcl_Size len) /* Length of string in bytes, or TCL_INDEX_NONE for * strlen(). */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ Tcl_Size result; Tcl_Obj *objPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { |
︙ | ︙ | |||
5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 | byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen); memcpy(byteArray + byteLen, dst, rawLen); byteLen += rawLen; bufPtr->nextRemoved += rawLen + skip; /* * Convert the buffer if there was an encoding. */ if (statePtr->encoding != GetBinaryEncoding()) { | > < | 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 | byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen); memcpy(byteArray + byteLen, dst, rawLen); byteLen += rawLen; bufPtr->nextRemoved += rawLen + skip; /* * Convert the buffer if there was an encoding. * XXX - unimplemented. */ if (statePtr->encoding != GetBinaryEncoding()) { } /* * Recycle all the emptied buffers. */ CommonGetsCleanup(chanPtr); |
︙ | ︙ | |||
5684 5685 5686 5687 5688 5689 5690 | *---------------------------------------------------------------------- */ Tcl_Size Tcl_Read( Tcl_Channel chan, /* The channel from which to read. */ char *dst, /* Where to store input read. */ | | | 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 | *---------------------------------------------------------------------- */ Tcl_Size Tcl_Read( Tcl_Channel chan, /* The channel from which to read. */ char *dst, /* Where to store input read. */ Tcl_Size bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ /* * This operation should occur at the top of a channel stack. |
︙ | ︙ | |||
5729 5730 5731 5732 5733 5734 5735 | *---------------------------------------------------------------------- */ Tcl_Size Tcl_ReadRaw( Tcl_Channel chan, /* The channel from which to read. */ char *readBuf, /* Where to store input read. */ | | | 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 | *---------------------------------------------------------------------- */ Tcl_Size Tcl_ReadRaw( Tcl_Channel chan, /* The channel from which to read. */ char *readBuf, /* Where to store input read. */ Tcl_Size bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ int copied = 0; assert(bytesToRead > 0); |
︙ | ︙ | |||
6780 6781 6782 6783 6784 6785 6786 | *---------------------------------------------------------------------- */ Tcl_Size Tcl_Ungets( Tcl_Channel chan, /* The channel for which to add the input. */ const char *str, /* The input itself. */ | | | 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 | *---------------------------------------------------------------------- */ Tcl_Size Tcl_Ungets( Tcl_Channel chan, /* The channel for which to add the input. */ const char *str, /* The input itself. */ Tcl_Size len, /* The length of the input. */ int atEnd) /* If non-zero, add at end of queue; otherwise * add at head of queue. */ { Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of actual channel. */ ChannelBuffer *bufPtr; /* Buffer to contain the data. */ int flags; |
︙ | ︙ | |||
7725 7726 7727 7728 7729 7730 7731 | * *---------------------------------------------------------------------- */ void Tcl_SetChannelBufferSize( Tcl_Channel chan, /* The channel whose buffer size to set. */ | | | 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 | * *---------------------------------------------------------------------- */ void Tcl_SetChannelBufferSize( Tcl_Channel chan, /* The channel whose buffer size to set. */ Tcl_Size sz) /* The size to set. */ { ChannelState *statePtr; /* State of real channel structure. */ /* * Clip the buffer size to force it into the [1,1M] range */ |
︙ | ︙ | |||
8706 8707 8708 8709 8710 8711 8712 | && GotFlag(statePtr, CHANNEL_NONBLOCKING) && bufPtr && !IsBufferEmpty(bufPtr) && !IsBufferFull(bufPtr)) { TclChannelPreserve((Tcl_Channel)chanPtr); statePtr->timerChanPtr = chanPtr; statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, | | | 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 8719 8720 8721 | && GotFlag(statePtr, CHANNEL_NONBLOCKING) && bufPtr && !IsBufferEmpty(bufPtr) && !IsBufferFull(bufPtr)) { TclChannelPreserve((Tcl_Channel)chanPtr); statePtr->timerChanPtr = chanPtr; statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ChannelTimerProc,chanPtr); } ChanWatch(chanPtr, mask); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
8756 8757 8758 8759 8760 8761 8762 | && GotFlag(statePtr, CHANNEL_NONBLOCKING) && !GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* * Restart the timer in case a channel handler reenters the event loop * before UpdateInterest gets called by Tcl_NotifyChannel. */ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, | | | | 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 8780 8781 8782 8783 8784 8785 8786 | && GotFlag(statePtr, CHANNEL_NONBLOCKING) && !GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* * Restart the timer in case a channel handler reenters the event loop * before UpdateInterest gets called by Tcl_NotifyChannel. */ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ChannelTimerProc,chanPtr); Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE); } else { /* The channel may have just been closed from within Tcl_NotifyChannel */ if (!GotFlag(statePtr, CHANNEL_INCLOSE)) { if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA) && (statePtr->interestMask & TCL_READABLE) && (statePtr->inQueueHead != NULL) && IsBufferReady(statePtr->inQueueHead)) { /* * Restart the timer in case a channel handler reenters the event loop * before UpdateInterest gets called by Tcl_NotifyChannel. */ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ChannelTimerProc,chanPtr); Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); } else { CleanupTimerHandler(statePtr); UpdateInterest(chanPtr); } } else { CleanupTimerHandler(statePtr); |
︙ | ︙ | |||
8834 8835 8836 8837 8838 8839 8840 | int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. Use 0 to disable a registered * handler. */ Tcl_ChannelProc *proc, /* Procedure to call for each selected * event. */ | | | 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 | int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. Use 0 to disable a registered * handler. */ Tcl_ChannelProc *proc, /* Procedure to call for each selected * event. */ void *clientData) /* Arbitrary data to pass to proc. */ { ChannelHandler *chPtr; Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ /* |
︙ | ︙ | |||
8906 8907 8908 8909 8910 8911 8912 | */ void Tcl_DeleteChannelHandler( Tcl_Channel chan, /* The channel for which to remove the * callback. */ Tcl_ChannelProc *proc, /* The procedure in the callback to delete. */ | | | 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 | */ void Tcl_DeleteChannelHandler( Tcl_Channel chan, /* The channel for which to remove the * callback. */ Tcl_ChannelProc *proc, /* The procedure in the callback to delete. */ void *clientData) /* The client data in the callback to * delete. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ChannelHandler *chPtr, *prevChPtr; Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ |
︙ | ︙ | |||
9112 9113 9114 9115 9116 9117 9118 | * Whatever the script does. * *---------------------------------------------------------------------- */ void TclChannelEventScriptInvoker( | | | 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 9127 | * Whatever the script does. * *---------------------------------------------------------------------- */ void TclChannelEventScriptInvoker( void *clientData, /* The script+interp record. */ TCL_UNUSED(int) /*mask*/) { EventScriptRecord *esPtr = (EventScriptRecord *)clientData; /* The event script + interpreter to eval it * in. */ Channel *chanPtr = esPtr->chanPtr; /* The channel for which this handler is |
︙ | ︙ | |||
9749 9750 9751 9752 9753 9754 9755 | sizeb = csPtr->bufSize; } else { sizeb = csPtr->toRead; } if (moveBytes) { size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb, | | | | | 9750 9751 9752 9753 9754 9755 9756 9757 9758 9759 9760 9761 9762 9763 9764 9765 9766 9767 9768 | sizeb = csPtr->bufSize; } else { sizeb = csPtr->toRead; } if (moveBytes) { size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb, !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)); } else { size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, !GotFlag(inStatePtr, CHANNEL_NONBLOCKING) ,0 /* No append */); /* * In case of a recoverable encoding error, any data before * the error should be written. This data is in the bufObj. * Program flow for this case: * - Check, if there are any remaining bytes to write * - If yes, simulate a successful read to write them out * - Come back here by the outer loop and read again |
︙ | ︙ | |||
10019 10020 10021 10022 10023 10024 10025 | *---------------------------------------------------------------------- */ static Tcl_Size DoRead( Channel *chanPtr, /* The channel from which to read. */ char *dst, /* Where to store input read. */ | | | 10020 10021 10022 10023 10024 10025 10026 10027 10028 10029 10030 10031 10032 10033 10034 | *---------------------------------------------------------------------- */ static Tcl_Size DoRead( Channel *chanPtr, /* The channel from which to read. */ char *dst, /* Where to store input read. */ Tcl_Size bytesToRead, /* Maximum number of bytes to read. */ int allowShortReads) /* Allow half-blocking (pipes,sockets) */ { ChannelState *statePtr = chanPtr->state; char *p = dst; /* * Early out when we know a read will get the eofchar. |
︙ | ︙ | |||
11386 11387 11388 11389 11390 11391 11392 | * representation. * *---------------------------------------------------------------------- */ static void DupChannelInternalRep( | | | | 11387 11388 11389 11390 11391 11392 11393 11394 11395 11396 11397 11398 11399 11400 11401 11402 11403 | * representation. * *---------------------------------------------------------------------- */ static void DupChannelInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have * an internal rep of type "Channel". */ Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { ResolvedChanName *resPtr; ChanGetInternalRep(srcPtr, resPtr); assert(resPtr); ChanSetInternalRep(copyPtr, resPtr); |
︙ | ︙ | |||
11443 11444 11445 11446 11447 11448 11449 | DumpFlags( char *str, int flags) { int i = 0; char buf[24]; | | | 11444 11445 11446 11447 11448 11449 11450 11451 11452 11453 11454 11455 11456 11457 11458 | DumpFlags( char *str, int flags) { int i = 0; char buf[24]; #define ChanFlag(chr, bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_')) ChanFlag('r', TCL_READABLE); ChanFlag('w', TCL_WRITABLE); ChanFlag('n', CHANNEL_NONBLOCKING); ChanFlag('l', CHANNEL_LINEBUFFERED); ChanFlag('u', CHANNEL_UNBUFFERED); ChanFlag('F', BG_FLUSH_SCHEDULED); |
︙ | ︙ |
Changes to generic/tclIO.h.
︙ | ︙ | |||
35 36 37 38 39 40 41 | * Buffers data being sent to or from a channel. */ typedef struct ChannelBuffer { Tcl_Size refCount; /* Current uses count */ Tcl_Size nextAdded; /* The next position into which a character * will be put in the buffer. */ | | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | * Buffers data being sent to or from a channel. */ typedef struct ChannelBuffer { Tcl_Size refCount; /* Current uses count */ Tcl_Size nextAdded; /* The next position into which a character * will be put in the buffer. */ Tcl_Size nextRemoved; /* Position of next byte to be removed from * the buffer. */ Tcl_Size bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; /* Next buffer in chain. */ char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real * buffer occupies this space + bufSize-1 * bytes. This must be the last field in the * structure. */ } ChannelBuffer; #define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf) |
︙ | ︙ | |||
92 93 94 95 96 97 98 | * data specific to the channel but which belongs to the generic part of the * Tcl channel mechanism, and it points at an instance specific (and type * specific) instance data, and at a channel type structure. */ typedef struct Channel { struct ChannelState *state; /* Split out state information */ | | | < | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | * data specific to the channel but which belongs to the generic part of the * Tcl channel mechanism, and it points at an instance specific (and type * specific) instance data, and at a channel type structure. */ typedef struct Channel { struct ChannelState *state; /* Split out state information */ void *instanceData; /* Instance-specific data provided by creator * of channel. */ const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ struct Channel *downChanPtr;/* Refers to channel this one was stacked * upon. This reference is NULL for normal * channels. See Tcl_StackChannel. */ struct Channel *upChanPtr; /* Refers to the channel above stacked this * one. NULL for the top most channel. */ /* |
︙ | ︙ | |||
212 213 214 215 216 217 218 | * TIP #219 ... Info for the I/O system ... * Error message set by channel drivers, for the propagation of arbitrary * Tcl errors. This information, if present (chanMsg not NULL), takes * precedence over a Posix error code returned by a channel operation. */ Tcl_Obj* chanMsg; | | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 | * TIP #219 ... Info for the I/O system ... * Error message set by channel drivers, for the propagation of arbitrary * Tcl errors. This information, if present (chanMsg not NULL), takes * precedence over a Posix error code returned by a channel operation. */ Tcl_Obj* chanMsg; Tcl_Obj* unreportedMsg; /* Non-NULL if an error report was deferred * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ size_t epoch; /* Used to test validity of stored channelname * lookup results. */ int maxPerms; /* TIP #220: Max access privileges * the channel was created with. */ |
︙ | ︙ |
Changes to generic/tclIOCmd.c.
︙ | ︙ | |||
365 366 367 368 369 370 371 | TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ | | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 | TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ Tcl_WideInt toRead; /* How many bytes to read? */ Tcl_Size charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *resultPtr, *chanObjPtr; if ((objc != 2) && (objc != 3)) { Interp *iPtr; argerror: |
︙ | ︙ | |||
1195 1196 1197 1198 1199 1200 1201 | * subsequently to eval accept scripts. * *---------------------------------------------------------------------- */ static void TcpAcceptCallbacksDeleteProc( | | | 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 | * subsequently to eval accept scripts. * *---------------------------------------------------------------------- */ static void TcpAcceptCallbacksDeleteProc( void *clientData, /* Data which was passed when the assocdata * was registered. */ TCL_UNUSED(Tcl_Interp *)) { Tcl_HashTable *hTblPtr = (Tcl_HashTable *)clientData; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; |
︙ | ︙ | |||
1323 1324 1325 1326 1327 1328 1329 | * Whatever the script does. * *---------------------------------------------------------------------- */ static void AcceptCallbackProc( | | | 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 | * Whatever the script does. * *---------------------------------------------------------------------- */ static void AcceptCallbackProc( void *callbackData, /* The data stored when the callback was * created in the call to * Tcl_OpenTcpServer. */ Tcl_Channel chan, /* Channel for the newly accepted * connection. */ char *address, /* Address of client that was accepted. */ int port) /* Port of client that was accepted. */ { |
︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 | * longer be informed. * *---------------------------------------------------------------------- */ static void TcpServerCloseProc( | | | 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 | * longer be informed. * *---------------------------------------------------------------------- */ static void TcpServerCloseProc( void *callbackData) /* The data passed in the call to * Tcl_CreateCloseHandler. */ { AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData; /* The actual data. */ if (acceptCallbackPtr->interp != NULL) { UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, |
︙ | ︙ |
Changes to generic/tclIOGT.c.
︙ | ︙ | |||
509 510 511 512 513 514 515 | * 0 if successful, errno when failed. * *---------------------------------------------------------------------- */ static int TransformBlockModeProc( | | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 | * 0 if successful, errno when failed. * *---------------------------------------------------------------------- */ static int TransformBlockModeProc( void *instanceData, /* State of transformation. */ int mode) /* New blocking mode. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; if (mode == TCL_MODE_NONBLOCKING) { dataPtr->flags |= CHANNEL_ASYNC; } else { |
︙ | ︙ | |||
844 845 846 847 848 849 850 | * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */ static long long TransformWideSeekProc( | | | 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 | * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */ static long long TransformWideSeekProc( void *instanceData, /* The channel to manipulate. */ long long offset, /* Size of movement. */ int mode, /* How to move. */ int *errorCodePtr) /* Location of error flag. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); |
︙ | ︙ | |||
1007 1008 1009 1010 1011 1012 1013 | * None. * *---------------------------------------------------------------------- */ static void TransformWatchProc( | | | 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 | * None. * *---------------------------------------------------------------------- */ static void TransformWatchProc( void *instanceData, /* Channel to watch. */ int mask) /* Events of interest. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel downChan; /* * The caller expressed interest in events occurring for this channel. We |
︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 | * The appropriate Tcl_File or NULL if not present. * *---------------------------------------------------------------------- */ static int TransformGetFileHandleProc( | | | | 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 | * The appropriate Tcl_File or NULL if not present. * *---------------------------------------------------------------------- */ static int TransformGetFileHandleProc( void *instanceData, /* Channel to query. */ int direction, /* Direction of interest. */ void **handlePtr) /* Place to store the handle into. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; /* * Return the handle belonging to parent channel. IOW, pass the request * down and the result up. */ |
︙ | ︙ | |||
1119 1120 1121 1122 1123 1124 1125 | * None. * *---------------------------------------------------------------------- */ static int TransformNotifyProc( | | | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 | * None. * *---------------------------------------------------------------------- */ static int TransformNotifyProc( void *clientData, /* The state of the notified * transformation. */ int mask) /* The mask of occurring events. */ { TransformChannelData *dataPtr = (TransformChannelData *)clientData; /* * An event occurred in the underlying channel. This transformation doesn't |
︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 | * None. * *---------------------------------------------------------------------- */ static void TransformChannelHandlerTimer( | | | 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 | * None. * *---------------------------------------------------------------------- */ static void TransformChannelHandlerTimer( void *clientData) /* Transformation to query. */ { TransformChannelData *dataPtr = (TransformChannelData *)clientData; dataPtr->timer = NULL; if (!(dataPtr->watchMask&TCL_READABLE) || ResultEmpty(&dataPtr->result)) { /* * The timer fired, but either is there no (more) interest in the |
︙ | ︙ |
Changes to generic/tclIORChan.c.
︙ | ︙ | |||
58 59 60 61 62 63 64 | static void TimerRunWrite(void *clientData); /* * The C layer channel type/driver definition used by the reflection. */ static const Tcl_ChannelType tclRChannelType = { | | | | | | | | | | | | | | | | | | | 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 | static void TimerRunWrite(void *clientData); /* * The C layer channel type/driver definition used by the reflection. */ static const Tcl_ChannelType tclRChannelType = { "tclrchannel", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ NULL, /* Old close API */ ReflectInput, /* Handle read request */ ReflectOutput, /* Handle write request */ NULL, ReflectSetOption, /* Set options. */ ReflectGetOption, /* Get options. */ ReflectWatch, /* Initialize notifier */ NULL, /* Get OS handle from the channel. */ ReflectClose, /* Close channel. Clean instance data */ ReflectBlock, /* Set blocking/nonblocking. */ NULL, /* Flush channel. */ NULL, /* Handle events. */ ReflectSeekWide, /* Move access point (64 bit). */ #if TCL_THREADS ReflectThread, /* thread action, tracking owner */ #else NULL, /* thread action */ #endif ReflectTruncate /* Truncate. */ }; /* * Instance data for a reflected channel. =========================== */ typedef struct { |
︙ | ︙ | |||
201 202 203 204 205 206 207 | (FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \ FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | \ FLAG(METH_CGETALL) | FLAG(METH_TRUNCATE)) #define RANDW \ (TCL_READABLE | TCL_WRITABLE) | | > | | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | (FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \ FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | \ FLAG(METH_CGETALL) | FLAG(METH_TRUNCATE)) #define RANDW \ (TCL_READABLE | TCL_WRITABLE) #define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) #define HAS(x,f) ((x) & FLAG(f)) #if TCL_THREADS /* * Thread specific types and structures. * * We are here essentially creating a very specific implementation of 'thread * send'. |
︙ | ︙ | |||
392 393 394 395 396 397 398 | */ static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr, ForwardedOperation op, const void *param); static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(void *clientData); | | | | | | | | | | | | < | | | | | | | | | | | | 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 | */ static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr, ForwardedOperation op, const void *param); static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(void *clientData); #define FreeReceivedError(p) \ if ((p)->base.mustFree) { \ Tcl_Free((p)->base.msgStr); \ } #define PassReceivedErrorInterp(i,p) \ if ((i) != NULL) { \ Tcl_SetChannelErrorInterp((i), \ Tcl_NewStringObj((p)->base.msgStr, -1)); \ } \ FreeReceivedError(p) #define PassReceivedError(c,p) \ Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ FreeReceivedError(p) #define ForwardSetStaticError(p,emsg) \ (p)->base.code = TCL_ERROR; \ (p)->base.mustFree = 0; \ (p)->base.msgStr = (char *) (emsg) #define ForwardSetDynamicError(p,emsg) \ (p)->base.code = TCL_ERROR; \ (p)->base.mustFree = 1; \ (p)->base.msgStr = (char *) (emsg) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); static ReflectedChannelMap * GetThreadReflectedChannelMap(void); static Tcl_ExitProc DeleteThreadReflectedChannelMap; #endif /* TCL_THREADS */ #define SetChannelErrorStr(c,msgStr) \ Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1)) static Tcl_Obj * MarshallError(Tcl_Interp *interp); static void UnmarshallErrorResult(Tcl_Interp *interp, Tcl_Obj *msgObj); /* * Static functions for this file: |
︙ | ︙ | |||
1754 1755 1756 1757 1758 1759 1760 | #endif blockObj = Tcl_NewBooleanObj(!nonblocking); Tcl_IncrRefCount(blockObj); Tcl_Preserve(rcPtr); | | | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 | #endif blockObj = Tcl_NewBooleanObj(!nonblocking); Tcl_IncrRefCount(blockObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr,METH_BLOCKING,blockObj,NULL,&resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); errorNum = EINVAL; } else { errorNum = EOK; } Tcl_DecrRefCount(blockObj); |
︙ | ︙ | |||
1824 1825 1826 1827 1828 1829 1830 | * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int ReflectSetOption( | | | 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 | * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int ReflectSetOption( void *clientData, /* Channel to query */ Tcl_Interp *interp, /* Interpreter to leave error messages in */ const char *optionName, /* Name of requested option */ const char *newValue) /* The new value */ { ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *optionObj, *valueObj; int result; /* Result code for 'configure' */ |
︙ | ︙ | |||
1866 1867 1868 1869 1870 1871 1872 | optionObj = Tcl_NewStringObj(optionName, -1); valueObj = Tcl_NewStringObj(newValue, -1); Tcl_IncrRefCount(optionObj); Tcl_IncrRefCount(valueObj); | | | 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 | optionObj = Tcl_NewStringObj(optionName, -1); valueObj = Tcl_NewStringObj(newValue, -1); Tcl_IncrRefCount(optionObj); Tcl_IncrRefCount(valueObj); result = InvokeTclMethod(rcPtr, METH_CONFIGURE,optionObj,valueObj, &resObj); if (result != TCL_OK) { UnmarshallErrorResult(interp, resObj); } Tcl_DecrRefCount(optionObj); Tcl_DecrRefCount(valueObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ |
︙ | ︙ | |||
1896 1897 1898 1899 1900 1901 1902 | * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int ReflectGetOption( | | | 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 | * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int ReflectGetOption( void *clientData, /* Channel to query */ Tcl_Interp *interp, /* Interpreter to leave error messages in */ const char *optionName, /* Name of reuqested option */ Tcl_DString *dsPtr) /* String to place the result into */ { /* * This code is special. It has regular passing of Tcl result, and errors. * The bypass functions are not required. |
︙ | ︙ | |||
2049 2050 2051 2052 2053 2054 2055 | * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int ReflectTruncate( | | | 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 | * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int ReflectTruncate( void *clientData, /* Channel to query */ long long length) /* Length to truncate to. */ { ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *lenObj; int errorNum; /* EINVAL or EOK (success). */ Tcl_Obj *resObj; /* Result for 'truncate' */ |
︙ | ︙ | |||
2085 2086 2087 2088 2089 2090 2091 | /* ASSERT: rcPtr->method & FLAG(METH_TRUNCATE) */ Tcl_Preserve(rcPtr); lenObj = Tcl_NewWideIntObj(length); Tcl_IncrRefCount(lenObj); | | | 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 | /* ASSERT: rcPtr->method & FLAG(METH_TRUNCATE) */ Tcl_Preserve(rcPtr); lenObj = Tcl_NewWideIntObj(length); Tcl_IncrRefCount(lenObj); if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); errorNum = EINVAL; } else { errorNum = EOK; } Tcl_DecrRefCount(lenObj); |
︙ | ︙ | |||
2132 2133 2134 2135 2136 2137 2138 | EncodeEventMask( Tcl_Interp *interp, const char *objName, Tcl_Obj *obj, int *mask) { int events; /* Mask of events to post */ | | | 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 | EncodeEventMask( Tcl_Interp *interp, const char *objName, Tcl_Obj *obj, int *mask) { int events; /* Mask of events to post */ Tcl_Size listc; /* #elements in eventspec list */ Tcl_Obj **listv; /* Elements of eventspec list */ int evIndex; /* Id of event for an element of the eventspec * list. */ if (TclListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ | |||
2370 2371 2372 2373 2374 2375 2376 | if (rcPtr->dead) { /* * The channel is marked as dead. Bail out immediately, with an * appropriate error. */ if (resultObjPtr != NULL) { | | | 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 | if (rcPtr->dead) { /* * The channel is marked as dead. Bail out immediately, with an * appropriate error. */ if (resultObjPtr != NULL) { resObj = Tcl_NewStringObj(msg_dstlost,-1); *resultObjPtr = resObj; Tcl_IncrRefCount(resObj); } /* * Not touching argOneObj, argTwoObj, they have not been used. * See the contract as well. |
︙ | ︙ | |||
2608 2609 2610 2611 2612 2613 2614 | rcPtr->cmd = NULL; } rcPtr->dead = 1; } static void DeleteReflectedChannelMap( | | | | | 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 | rcPtr->cmd = NULL; } rcPtr->dead = 1; } static void DeleteReflectedChannelMap( void *clientData, /* The per-interpreter data structure. */ Tcl_Interp *interp) /* The interpreter being deleted. */ { ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)clientData; /* The map */ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedChannel *rcPtr; Tcl_Channel chan; #if TCL_THREADS ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; #endif |
︙ | ︙ | |||
3334 3335 3336 3337 3338 3339 3340 | break; case ForwardedTruncate: { Tcl_Obj *lenObj = Tcl_NewWideIntObj(paramPtr->truncate.length); Tcl_IncrRefCount(lenObj); Tcl_Preserve(rcPtr); | | | 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 | break; case ForwardedTruncate: { Tcl_Obj *lenObj = Tcl_NewWideIntObj(paramPtr->truncate.length); Tcl_IncrRefCount(lenObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); Tcl_DecrRefCount(lenObj); break; } |
︙ | ︙ |
Changes to generic/tclIORTrans.c.
︙ | ︙ | |||
205 206 207 208 209 210 211 | #define FLAG(m) (1 << (m)) #define REQUIRED_METHODS \ (FLAG(METH_INIT) | FLAG(METH_FINAL)) #define RANDW \ (TCL_READABLE | TCL_WRITABLE) | | | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 | #define FLAG(m) (1 << (m)) #define REQUIRED_METHODS \ (FLAG(METH_INIT) | FLAG(METH_FINAL)) #define RANDW \ (TCL_READABLE | TCL_WRITABLE) #define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) #define HAS(x,f) ((x) & FLAG(f)) #if TCL_THREADS /* * Thread specific types and structures. * * We are here essentially creating a very specific implementation of 'thread * send'. |
︙ | ︙ | |||
352 353 354 355 356 357 358 | */ static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr, ForwardedOperation op, const void *param); static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(void *clientData); | | | | | | | | | | | | | | | | | | | | | | | | 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 | */ static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr, ForwardedOperation op, const void *param); static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(void *clientData); #define FreeReceivedError(p) \ do { \ if ((p)->base.mustFree) { \ Tcl_Free((p)->base.msgStr); \ } \ } while (0) #define PassReceivedErrorInterp(i,p) \ do { \ if ((i) != NULL) { \ Tcl_SetChannelErrorInterp((i), \ Tcl_NewStringObj((p)->base.msgStr, -1)); \ } \ FreeReceivedError(p); \ } while (0) #define PassReceivedError(c,p) \ do { \ Tcl_SetChannelError((c), \ Tcl_NewStringObj((p)->base.msgStr, -1)); \ FreeReceivedError(p); \ } while (0) #define ForwardSetStaticError(p,emsg) \ do { \ (p)->base.code = TCL_ERROR; \ (p)->base.mustFree = 0; \ (p)->base.msgStr = (char *) (emsg); \ } while (0) #define ForwardSetDynamicError(p,emsg) \ do { \ (p)->base.code = TCL_ERROR; \ (p)->base.mustFree = 1; \ (p)->base.msgStr = (char *) (emsg); \ } while (0) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); static ReflectedTransformMap * GetThreadReflectedTransformMap(void); static void DeleteThreadReflectedTransformMap( void *clientData); #endif /* TCL_THREADS */ #define SetChannelErrorStr(c,msgStr) \ Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1)) static Tcl_Obj * MarshallError(Tcl_Interp *interp); static void UnmarshallErrorResult(Tcl_Interp *interp, Tcl_Obj *msgObj); /* * Static functions for this file: |
︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 | if (rtPtr->dead) { /* * The transform is marked as dead. Bail out immediately, with an * appropriate error. */ if (resultObjPtr != NULL) { | | | 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 | if (rtPtr->dead) { /* * The transform is marked as dead. Bail out immediately, with an * appropriate error. */ if (resultObjPtr != NULL) { resObj = Tcl_NewStringObj(msg_dstlost,-1); *resultObjPtr = resObj; Tcl_IncrRefCount(resObj); } return TCL_ERROR; } /* |
︙ | ︙ |
Changes to generic/tclIOSock.c.
︙ | ︙ | |||
186 187 188 189 190 191 192 | const char *family = NULL; Tcl_DString ds; int result; if (host != NULL) { if (Tcl_UtfToExternalDStringEx(interp, NULL, host, -1, 0, &ds, NULL) != TCL_OK) { | | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | const char *family = NULL; Tcl_DString ds; int result; if (host != NULL) { if (Tcl_UtfToExternalDStringEx(interp, NULL, host, -1, 0, &ds, NULL) != TCL_OK) { Tcl_DStringFree(&ds); return 0; } native = Tcl_DStringValue(&ds); } /* * Workaround for OSX's apparent inability to resolve "localhost", "0" |
︙ | ︙ | |||
258 259 260 261 262 263 264 | if (result != 0) { *errorMsgPtr = #ifdef EAI_SYSTEM /* Doesn't exist on Windows */ (result == EAI_SYSTEM) ? Tcl_PosixError(interp) : #endif /* EAI_SYSTEM */ gai_strerror(result); | | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 | if (result != 0) { *errorMsgPtr = #ifdef EAI_SYSTEM /* Doesn't exist on Windows */ (result == EAI_SYSTEM) ? Tcl_PosixError(interp) : #endif /* EAI_SYSTEM */ gai_strerror(result); return 0; } /* * Put IPv4 addresses before IPv6 addresses to maximize backwards * compatibility of [fconfigure -sockname] output. * * There might be more elegant/efficient ways to do this. |
︙ | ︙ |
Changes to generic/tclIOUtil.c.
︙ | ︙ | |||
241 242 243 244 245 246 247 | Tcl_Stat( const char *path, /* Pathname of file to stat (in current system * encoding). */ struct stat *oldStyleBuf) /* Filled with results of stat call. */ { int ret; Tcl_StatBuf buf; | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | Tcl_Stat( const char *path, /* Pathname of file to stat (in current system * encoding). */ struct stat *oldStyleBuf) /* Filled with results of stat call. */ { int ret; Tcl_StatBuf buf; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSStat(pathPtr, &buf); Tcl_DecrRefCount(pathPtr); if (ret != -1) { #ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt tmp1, tmp2, tmp3 = 0; |
︙ | ︙ | |||
328 329 330 331 332 333 334 | int Tcl_Access( const char *path, /* Pathname of file to access (in current * system encoding). */ int mode) /* Permission setting. */ { int ret; | | | | | | 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 | int Tcl_Access( const char *path, /* Pathname of file to access (in current * system encoding). */ int mode) /* Permission setting. */ { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSAccess(pathPtr,mode); Tcl_DecrRefCount(pathPtr); return ret; } /* Obsolete */ Tcl_Channel Tcl_OpenFileChannel( Tcl_Interp *interp, /* Interpreter for error reporting. May be * NULL. */ const char *path, /* Pathname of file to open. */ const char *modeString, /* A list of POSIX open modes or a string such * as "rw". */ int permissions) /* The modes to use if creating a new file. */ { Tcl_Channel ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions); Tcl_DecrRefCount(pathPtr); return ret; } /* Obsolete */ int Tcl_Chdir( const char *dirName) { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSChdir(pathPtr); Tcl_DecrRefCount(pathPtr); return ret; } /* Obsolete */ |
︙ | ︙ | |||
395 396 397 398 399 400 401 | Tcl_EvalFile( Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */ const char *fileName) /* Pathname of the file containing the script. * Performs Tilde-substitution on this * pathaname. */ { int ret; | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 | Tcl_EvalFile( Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */ const char *fileName) /* Pathname of the file containing the script. * Performs Tilde-substitution on this * pathaname. */ { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSEvalFile(interp, pathPtr); Tcl_DecrRefCount(pathPtr); return ret; } |
︙ | ︙ | |||
1565 1566 1567 1568 1569 1570 1571 | } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { if (mode & O_APPEND) { accessFlagRepeated: if (interp) { TclPrintfResult(interp, "access mode \"%s\" repeated", flag); } | | | | 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 | } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { if (mode & O_APPEND) { accessFlagRepeated: if (interp) { TclPrintfResult(interp, "access mode \"%s\" repeated", flag); } goto invAccessMode; } mode |= O_APPEND; *modeFlagsPtr |= 1; } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { if (mode & O_CREAT) { goto accessFlagRepeated; } mode |= O_CREAT; } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { if (mode & O_EXCL) { goto accessFlagRepeated; } mode |= O_EXCL; |
︙ | ︙ | |||
1728 1729 1730 1731 1732 1733 1734 | */ if (encodingName == NULL) { encodingName = "utf-8"; } if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { | | | 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 | */ if (encodingName == NULL) { encodingName = "utf-8"; } if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { Tcl_CloseEx(interp,chan,0); return result; } TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); /* |
︙ | ︙ | |||
1999 2000 2001 2002 2003 2004 2005 | /* *---------------------------------------------------------------------- * * Tcl_SetErrno -- * * Sets the Tcl error code to the given value. On some saner platforms | | | 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 | /* *---------------------------------------------------------------------- * * Tcl_SetErrno -- * * Sets the Tcl error code to the given value. On some saner platforms * this is implemented in the C library as a thread-local value , but this * is *really* unsafe to assume! * * Results: * None. * * Side effects: * Modifies the the Tcl error code value. |
︙ | ︙ | |||
2351 2352 2353 2354 2355 2356 2357 | static int NativeFileAttrsGet( Tcl_Interp *interp, /* The interpreter for error reporting. */ int index, /* index of the attribute command. */ Tcl_Obj *pathPtr, /* Pathname of the file */ Tcl_Obj **objPtrRef) /* Where to store the a pointer to the result. */ { | | | 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 | static int NativeFileAttrsGet( Tcl_Interp *interp, /* The interpreter for error reporting. */ int index, /* index of the attribute command. */ Tcl_Obj *pathPtr, /* Pathname of the file */ Tcl_Obj **objPtrRef) /* Where to store the a pointer to the result. */ { return tclpFileAttrProcs[index].getProc(interp, index, pathPtr,objPtrRef); } /* *---------------------------------------------------------------------- * * NativeFileAttrsSet -- * |
︙ | ︙ | |||
2646 2647 2648 2649 2650 2651 2652 | /* * Found the pathname of the current directory. */ retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd); Tcl_IncrRefCount(retVal); | | | 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 | /* * Found the pathname of the current directory. */ retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd); Tcl_IncrRefCount(retVal); norm = TclFSNormalizeAbsolutePath(interp,retVal); if (norm != NULL) { /* * Assign to global storage the pathname of the current * directory and copy it into thread-local storage as * well. * * At system startup multiple threads could in principle |
︙ | ︙ | |||
2778 2779 2780 2781 2782 2783 2784 | FsUpdateCwd(NULL, NULL); goto cdDidNotChange; } norm = TclFSNormalizeAbsolutePath(interp, retVal); if (norm == NULL) { | | | | 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 | FsUpdateCwd(NULL, NULL); goto cdDidNotChange; } norm = TclFSNormalizeAbsolutePath(interp, retVal); if (norm == NULL) { /* * 'norm' shouldn't ever be NULL, but we are careful. */ /* Do nothing */ if (retCd != NULL) { fsPtr->freeInternalRepProc(retCd); } } else if (norm == tsdPtr->cwdPathPtr) { goto cdEqual; } else { /* * Determine whether the filesystem's answer is the same as the * cached local value. Since both 'norm' and 'tsdPtr->cwdPathPtr' * are normalized pathnames, do something more efficient than * calling 'Tcl_FSEqualPaths', and in addition avoid a nasty * infinite loop bug when trying to normalize tsdPtr->cwdPathPtr. */ |
︙ | ︙ | |||
4005 4006 4007 4008 4009 4010 4011 | while (numVolumes > 0) { Tcl_Obj *vol; Tcl_Size len; const char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); | | | 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 | while (numVolumes > 0) { Tcl_Obj *vol; Tcl_Size len; const char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); strVol = TclGetStringFromObj(vol,&len); if (pathLen < len) { continue; } if (strncmp(strVol, path, len) == 0) { type = TCL_PATH_ABSOLUTE; if (filesystemPtrPtr != NULL) { *filesystemPtrPtr = fsRecPtr->fsPtr; |
︙ | ︙ | |||
4627 4628 4629 4630 4631 4632 4633 | case TCL_PLATFORM_UNIX: separator = "/"; break; case TCL_PLATFORM_WINDOWS: separator = "\\"; break; } | | | 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 | case TCL_PLATFORM_UNIX: separator = "/"; break; case TCL_PLATFORM_WINDOWS: separator = "\\"; break; } return Tcl_NewStringObj(separator,1); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclIndexObj.c.
︙ | ︙ | |||
51 52 53 54 55 56 57 | * 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 */ | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | * 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 */ Tcl_Size offset; /* Offset between table entries */ Tcl_Size index; /* Selected index into table. */ } IndexRep; /* * The following macros greatly simplify moving through a table... */ |
︙ | ︙ | |||
278 279 280 281 282 283 284 | done: /* * 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. */ | | < | | | | | | | | | | | | | 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 | done: /* * 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 && (index != TCL_INDEX_NONE) && !(flags & TCL_INDEX_TEMP_TABLE)) { irPtr = TclFetchInternalRep(objPtr, &tclIndexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; } else { Tcl_ObjInternalRep ir; indexRep = (IndexRep*)Tcl_Alloc(sizeof(IndexRep)); ir.twoPtrValue.ptr1 = indexRep; Tcl_StoreInternalRep(objPtr, &tclIndexType, &ir); } indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; indexRep->index = index; } uncachedDone: if (indexPtr != NULL) { flags &= (30-(int)(sizeof(int)<<1)); if (flags) { if (flags == sizeof(uint16_t)<<1) { |
︙ | ︙ | |||
800 801 802 803 804 805 806 | * *---------------------------------------------------------------------- */ void Tcl_WrongNumArgs( Tcl_Interp *interp, /* Current interpreter. */ | | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 | * *---------------------------------------------------------------------- */ void Tcl_WrongNumArgs( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments to print from objv. */ Tcl_Obj *const objv[], /* Initial argument objects, which should be * included in the error message. */ const char *message) /* Error message to print after the leading * objects in objv. The message may be * NULL. */ { Tcl_Obj *objPtr; |
︙ | ︙ | |||
996 997 998 999 1000 1001 1002 | * processed here. Should be NULL if no return * of arguments is desired. */ { Tcl_Obj **leftovers; /* Array to write back to remObjv on * successful exit. Will include the name of * the command. */ Tcl_Size nrem; /* Size of leftovers.*/ | | > | | | | 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 | * processed here. Should be NULL if no return * of arguments is desired. */ { Tcl_Obj **leftovers; /* Array to write back to remObjv on * successful exit. Will include the name of * the command. */ Tcl_Size nrem; /* Size of leftovers.*/ const Tcl_ArgvInfo *infoPtr; /* Pointer to the current entry in the table * of argument descriptions. */ const Tcl_ArgvInfo *matchPtr; /* Descriptor that matches current argument */ Tcl_Obj *curArg; /* Current argument */ const char *str = NULL; char c; /* Second character of current arg (used for * quick check for matching; use 2nd char. * because first char. will almost always be * '-'). */ Tcl_Size srcIndex; /* Location from which to read next argument * from objv. */ Tcl_Size dstIndex; /* Used to keep track of current arguments * being processed, primarily for error * reporting. */ Tcl_Size objc; /* # arguments in objv still to process. */ Tcl_Size length; /* Number of characters in current argument */ Tcl_Size gf_ret; /* Return value from Tcl_ArgvGenFuncProc*/ if (remObjv != NULL) { |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
786 787 788 789 790 791 792 | #define TclSetVarConstant(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_CONSTANT #define TclSetVarArrayElement(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT #define TclSetVarUndefined(varPtr) \ | | | | | | | | | | | | | | 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 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 | #define TclSetVarConstant(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_CONSTANT #define TclSetVarArrayElement(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT #define TclSetVarUndefined(varPtr) \ (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK|VAR_CONSTANT);\ (varPtr)->value.objPtr = NULL #define TclClearVarUndefined(varPtr) #define TclSetVarTraceActive(varPtr) \ (varPtr)->flags |= VAR_TRACE_ACTIVE #define TclClearVarTraceActive(varPtr) \ (varPtr)->flags &= ~VAR_TRACE_ACTIVE #define TclSetVarNamespaceVar(varPtr) \ if (!TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags |= VAR_NAMESPACE_VAR;\ if (TclIsVarInHash(varPtr)) {\ ((VarInHash *)(varPtr))->refCount++;\ }\ } #define TclClearVarNamespaceVar(varPtr) \ if (TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\ if (TclIsVarInHash(varPtr)) {\ ((VarInHash *)(varPtr))->refCount--;\ }\ } /* * Macros to read various flag bits of variables. * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE int TclIsVarScalar(Var *varPtr); * MODULE_SCOPE int TclIsVarConstant(Var *varPtr); * MODULE_SCOPE int TclIsVarLink(Var *varPtr); * MODULE_SCOPE int TclIsVarArray(Var *varPtr); * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr); * MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr); * MODULE_SCOPE int TclIsVarTemporary(Var *varPtr); * MODULE_SCOPE int TclIsVarArgument(Var *varPtr); * MODULE_SCOPE int TclIsVarResolved(Var *varPtr); */ #define TclVarFindHiddenArray(varPtr,arrayPtr) \ do { \ if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) && \ (TclVarParentArray(varPtr) != NULL)) { \ arrayPtr = TclVarParentArray(varPtr); \ } \ } while(0) |
︙ | ︙ | |||
880 881 882 883 884 885 886 | #define TclIsVarInHash(varPtr) \ ((varPtr)->flags & VAR_IN_HASHTABLE) #define TclIsVarDeadHash(varPtr) \ ((varPtr)->flags & VAR_DEAD_HASH) #define TclGetVarNsPtr(varPtr) \ | | | | | | < | | < | | | | 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 909 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 | #define TclIsVarInHash(varPtr) \ ((varPtr)->flags & VAR_IN_HASHTABLE) #define TclIsVarDeadHash(varPtr) \ ((varPtr)->flags & VAR_DEAD_HASH) #define TclGetVarNsPtr(varPtr) \ (TclIsVarInHash(varPtr) \ ? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \ : NULL) #define TclVarParentArray(varPtr) \ ((TclVarHashTable *) ((VarInHash *) (varPtr))->entry.tablePtr)->arrayPtr #define VarHashRefCount(varPtr) \ ((VarInHash *) (varPtr))->refCount #define VarHashGetKey(varPtr) \ (((VarInHash *)(varPtr))->entry.key.objPtr) /* * Macros for direct variable access by TEBC. */ #define TclIsVarTricky(varPtr,trickyFlags) \ ( ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags)) \ || (TclIsVarInHash(varPtr) \ && (TclVarParentArray(varPtr) != NULL) \ && (TclVarParentArray(varPtr)->flags & (trickyFlags)))) #define TclIsVarDirectReadable(varPtr) \ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectWritable(varPtr) \ (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH|VAR_CONSTANT)) #define TclIsVarDirectUnsettable(varPtr) \ (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH|VAR_CONSTANT)) #define TclIsVarDirectModifyable(varPtr) \ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_CONSTANT)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectReadable2(varPtr, arrayPtr) \ (TclIsVarDirectReadable(varPtr) &&\ (!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_READ))) #define TclIsVarDirectWritable2(varPtr, arrayPtr) \ (TclIsVarDirectWritable(varPtr) &&\ (!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_WRITE))) #define TclIsVarDirectModifyable2(varPtr, arrayPtr) \ (TclIsVarDirectModifyable(varPtr) &&\ (!(arrayPtr) || !((arrayPtr)->flags & (VAR_TRACED_READ|VAR_TRACED_WRITE)))) /* *---------------------------------------------------------------- * Data structures related to procedures. These are used primarily in * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- |
︙ | ︙ | |||
1100 1101 1102 1103 1104 1105 1106 | * "leavestep" traces. */ #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 #if TCL_MAJOR_VERSION > 8 | | < | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 | * "leavestep" traces. */ #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 #if TCL_MAJOR_VERSION > 8 #define TclObjTypeHasProc(objPtr, proc) (((objPtr)->typePtr \ && ((offsetof(Tcl_ObjType, proc) < offsetof(Tcl_ObjType, version)) \ || (offsetof(Tcl_ObjType, proc) < (objPtr)->typePtr->version))) ? \ ((objPtr)->typePtr)->proc : NULL) MODULE_SCOPE Tcl_Size TclLengthOne(Tcl_Obj *); /* |
︙ | ︙ | |||
2620 2621 2622 2623 2624 2625 2626 | * be a list (tclListType). Will crash otherwise. * TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not * be tclListType. These will convert as needed and return error if * conversion not possible. */ /* Returns the starting slot for this listRep in the contained ListStore */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 | * be a list (tclListType). Will crash otherwise. * TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not * be tclListType. These will convert as needed and return error if * conversion not possible. */ /* Returns the starting slot for this listRep in the contained ListStore */ #define ListRepStart(listRepPtr_) \ ((listRepPtr_)->spanPtr \ ? (listRepPtr_)->spanPtr->spanStart \ : (listRepPtr_)->storePtr->firstUsed) /* Returns the number of elements in this listRep */ #define ListRepLength(listRepPtr_) \ ((listRepPtr_)->spanPtr \ ? (listRepPtr_)->spanPtr->spanLength \ : (listRepPtr_)->storePtr->numUsed) /* Returns a pointer to the first slot containing this ListRep elements */ #define ListRepElementsBase(listRepPtr_) \ (&(listRepPtr_)->storePtr->slots[ListRepStart(listRepPtr_)]) /* Stores the number of elements and base address of the element array */ #define ListRepElements(listRepPtr_, objc_, objv_) \ (((objv_) = ListRepElementsBase(listRepPtr_)), \ ((objc_) = ListRepLength(listRepPtr_))) /* Returns 1/0 whether the ListRep's ListStore is shared. */ #define ListRepIsShared(listRepPtr_) ((listRepPtr_)->storePtr->refCount > 1) /* Returns a pointer to the ListStore component */ #define ListObjStorePtr(listObj_) \ ((ListStore *)((listObj_)->internalRep.twoPtrValue.ptr1)) /* Returns a pointer to the ListSpan component */ #define ListObjSpanPtr(listObj_) \ ((ListSpan *)((listObj_)->internalRep.twoPtrValue.ptr2)) /* Returns the ListRep internal representaton in a Tcl_Obj */ #define ListObjGetRep(listObj_, listRepPtr_) \ do { \ (listRepPtr_)->storePtr = ListObjStorePtr(listObj_); \ (listRepPtr_)->spanPtr = ListObjSpanPtr(listObj_); \ } while (0) /* Returns the length of the list */ #define ListObjLength(listObj_, len_) \ ((len_) = ListObjSpanPtr(listObj_) \ ? ListObjSpanPtr(listObj_)->spanLength \ : ListObjStorePtr(listObj_)->numUsed) /* Returns the starting slot index of this list's elements in the ListStore */ #define ListObjStart(listObj_) \ (ListObjSpanPtr(listObj_) \ ? ListObjSpanPtr(listObj_)->spanStart \ : ListObjStorePtr(listObj_)->firstUsed) /* Stores the element count and base address of this list's elements */ #define ListObjGetElements(listObj_, objc_, objv_) \ (((objv_) = &ListObjStorePtr(listObj_)->slots[ListObjStart(listObj_)]), \ (ListObjLength(listObj_, (objc_)))) /* * Returns 1/0 whether the internal representation (not the Tcl_Obj itself) * is shared. Note by intent this only checks for sharing of ListStore, * not spans. */ #define ListObjRepIsShared(listObj_) \ (ListObjStorePtr(listObj_)->refCount > 1) /* * Certain commands like concat are optimized if an existing string * representation of a list object is known to be in canonical format (i.e. * generated from the list representation). There are three conditions when * this will be the case: * (1) No string representation exists which means it will obviously have * to be generated from the list representation when needed * (2) The ListStore flags is marked canonical. This is done at the time * the string representation is generated from the list under certain * conditions (see comments in UpdateStringOfList). * (3) The list representation does not have a span component. This is * because list Tcl_Obj's with spans are always created from existing lists * and never from strings (see SetListFromAny) and thus their string * representation will always be canonical. */ #define ListObjIsCanonical(listObj_) \ (((listObj_)->bytes == NULL) \ || (ListObjStorePtr(listObj_)->flags & LISTSTORE_CANONICAL) \ || ListObjSpanPtr(listObj_) != NULL) /* * Converts the Tcl_Obj to a list if it isn't one and stores the element * count and base address of this list's elements in objcPtr_ and objvPtr_. * Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be * converted to a list. */ #define TclListObjGetElements(interp_, listObj_, objcPtr_, objvPtr_) \ ((TclHasInternalRep((listObj_), &tclListType)) \ ? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \ TCL_OK) \ : Tcl_ListObjGetElements( \ (interp_), (listObj_), (objcPtr_), (objvPtr_))) /* * Converts the Tcl_Obj to a list if it isn't one and stores the element * count in lenPtr_. Returns TCL_OK on success or TCL_ERROR if the * Tcl_Obj cannot be converted to a list. */ #define TclListObjLength(interp_, listObj_, lenPtr_) \ ((TclHasInternalRep((listObj_), &tclListType)) \ ? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \ : Tcl_ListObjLength((interp_), (listObj_), (lenPtr_))) #define TclListObjIsCanonical(listObj_) \ ((TclHasInternalRep((listObj_), &tclListType)) \ ? ListObjIsCanonical((listObj_)) \ : 0) /* * Modes for collecting (or not) in the implementations of TclNRForeachCmd, * TclNRLmapCmd and their compilations. */ |
︙ | ︙ | |||
2965 2966 2967 2968 2969 2970 2971 | *---------------------------------------------------------------------- * Internal convenience macros for manipulating encoding flags. See * TCL_ENCODING_PROFILE_* in tcl.h *---------------------------------------------------------------------- */ #define ENCODING_PROFILE_MASK 0xFF000000 | | | | | | | 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 | *---------------------------------------------------------------------- * Internal convenience macros for manipulating encoding flags. See * TCL_ENCODING_PROFILE_* in tcl.h *---------------------------------------------------------------------- */ #define ENCODING_PROFILE_MASK 0xFF000000 #define ENCODING_PROFILE_GET(flags_) \ ((flags_) & ENCODING_PROFILE_MASK) #define ENCODING_PROFILE_SET(flags_, profile_) \ do { \ (flags_) &= ~ENCODING_PROFILE_MASK; \ (flags_) |= ((profile_) & ENCODING_PROFILE_MASK); \ } while (0) /* *---------------------------------------------------------------------- * Common functions for calculating overallocation. Trivial but allows for * experimenting with growth factors without having to change code in * multiple places. See TclAttemptAllocElemsEx and similar for usage |
︙ | ︙ | |||
3214 3215 3216 3217 3218 3219 3220 | Tcl_Obj *body; /* Loop body. */ Tcl_Obj *next; /* Loop step script, NULL for 'while'. */ const char *msg; /* Error message part. */ Tcl_Size word; /* Index of the body script in the command */ } ForIterData; /* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile | | | | 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 | Tcl_Obj *body; /* Loop body. */ Tcl_Obj *next; /* Loop step script, NULL for 'while'. */ const char *msg; /* Error message part. */ Tcl_Size word; /* Index of the body script in the command */ } ForIterData; /* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile * and Tcl_FindSymbol. This structure corresponds to an opaque * typedef in tcl.h */ typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, const char* symbol); struct Tcl_LoadHandle_ { void *clientData; /* Client data is the load handle in the * native filesystem if a module was loaded * there, or an opaque pointer to a structure |
︙ | ︙ | |||
4275 4276 4277 4278 4279 4280 4281 | * * Note that the optimiser should resolve the case (interp==NULL) at compile * time. */ # define ALLOC_NOBJHIGH 1200 | | | | < | | 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 | * * Note that the optimiser should resolve the case (interp==NULL) at compile * time. */ # define ALLOC_NOBJHIGH 1200 # define TclAllocObjStorageEx(interp, objPtr) \ do { \ AllocCache *cachePtr; \ if (((interp) == NULL) || \ ((cachePtr = ((Interp *)(interp))->allocCache), \ (cachePtr->numObjects == 0))) { \ (objPtr) = TclThreadAllocObj(); \ } else { \ (objPtr) = cachePtr->firstObjPtr; \ cachePtr->firstObjPtr = (Tcl_Obj *)(objPtr)->internalRep.twoPtrValue.ptr1; \ --cachePtr->numObjects; \ } \ } while (0) # define TclFreeObjStorageEx(interp, objPtr) \ do { \ AllocCache *cachePtr; \ if (((interp) == NULL) || \ ((cachePtr = ((Interp *)(interp))->allocCache), \ ((cachePtr->numObjects == 0) || \ (cachePtr->numObjects >= ALLOC_NOBJHIGH)))) { \ TclThreadFreeObj(objPtr); \ |
︙ | ︙ | |||
4345 4346 4347 4348 4349 4350 4351 | #endif #else /* TCL_MEM_DEBUG */ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, int line); # define TclDbNewObj(objPtr, file, line) \ | | | 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 | #endif #else /* TCL_MEM_DEBUG */ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, int line); # define TclDbNewObj(objPtr, file, line) \ do { \ TclIncrObjsAllocated(); \ (objPtr) = (Tcl_Obj *) \ Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ TclDbInitNewObj((objPtr), (file), (line)); \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) |
︙ | ︙ | |||
4458 4459 4460 4461 4462 4463 4464 | * * MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclInvalidateStringRep(objPtr) \ do { \ | | | 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 | * * MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclInvalidateStringRep(objPtr) \ do { \ Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr); \ if (_isobjPtr->bytes != NULL) { \ if (_isobjPtr->bytes != &tclEmptyString) { \ Tcl_Free((char *)_isobjPtr->bytes); \ } \ _isobjPtr->bytes = NULL; \ } \ } while (0) |
︙ | ︙ | |||
4969 4970 4971 4972 4973 4974 4975 | TclIncrObjsAllocated(); \ TclAllocObjStorageEx((interp), (_objPtr)); \ *(void **)&(memPtr) = (void *) (_objPtr); \ } while (0) #define TclSmallFreeEx(interp, memPtr) \ do { \ | | | | 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 | TclIncrObjsAllocated(); \ TclAllocObjStorageEx((interp), (_objPtr)); \ *(void **)&(memPtr) = (void *) (_objPtr); \ } while (0) #define TclSmallFreeEx(interp, memPtr) \ do { \ TclFreeObjStorageEx((interp), (Tcl_Obj *)(memPtr)); \ TclIncrObjsFreed(); \ } while (0) #else /* TCL_MEM_DEBUG */ #define TclSmallAllocEx(interp, nbytes, memPtr) \ do { \ Tcl_Obj *_objPtr; \ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ TclNewObj(_objPtr); \ *(void **)&(memPtr) = (void *)_objPtr; \ } while (0) #define TclSmallFreeEx(interp, memPtr) \ do { \ Tcl_Obj *_objPtr = (Tcl_Obj *)(memPtr); \ _objPtr->bytes = NULL; \ _objPtr->typePtr = NULL; \ _objPtr->refCount = 1; \ TclDecrRefCount(_objPtr); \ } while (0) #endif /* TCL_MEM_DEBUG */ |
︙ | ︙ |
Changes to generic/tclInterp.c.
︙ | ︙ | |||
192 193 194 195 196 197 198 | LimitHandler *prevPtr; /* Previous item in linked list of * handlers. */ LimitHandler *nextPtr; /* Next item in linked list of handlers. */ }; /* * Values for the LimitHandler flags field. | | | | | | | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 | LimitHandler *prevPtr; /* Previous item in linked list of * handlers. */ LimitHandler *nextPtr; /* Next item in linked list of handlers. */ }; /* * Values for the LimitHandler flags field. * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being * processed; handlers are never to be reentered. * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This * should not normally be observed because when a handler is * deleted it is also spliced out of the list of handlers, but * even so we will be careful. */ #define LIMIT_HANDLER_ACTIVE 0x01 #define LIMIT_HANDLER_DELETED 0x02 /* * Prototypes for local static functions: |
︙ | ︙ | |||
596 597 598 599 600 601 602 | * *---------------------------------------------------------------------- */ int Tcl_InterpObjCmd( void *clientData, | | | | | | | | 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 | * *---------------------------------------------------------------------- */ int Tcl_InterpObjCmd( void *clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); } static int NRInterpCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *childInterp; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", "children", "create", "debug", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", |
︙ | ︙ | |||
1002 1003 1004 1005 1006 1007 1008 | } if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, &limitType) != TCL_OK) { return TCL_ERROR; } switch (limitType) { case LIMIT_TYPE_COMMANDS: | | | 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 | } if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, &limitType) != TCL_OK) { return TCL_ERROR; } switch (limitType) { case LIMIT_TYPE_COMMANDS: return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv); case LIMIT_TYPE_TIME: return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv); } } break; case OPT_MARKTRUSTED: if (objc != 3) { |
︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 | *--------------------------------------------------------------------------- */ static Tcl_Interp * GetInterp2( Tcl_Interp *interp, /* Default interp if no interp was specified * on the command line. */ | | | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 | *--------------------------------------------------------------------------- */ static Tcl_Interp * GetInterp2( Tcl_Interp *interp, /* Default interp if no interp was specified * on the command line. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc == 2) { return interp; } else if (objc == 3) { return GetInterp(interp, objv[2]); } else { |
︙ | ︙ | |||
1192 1193 1194 1195 1196 1197 1198 | int Tcl_CreateAlias( Tcl_Interp *childInterp, /* Interpreter for source command. */ const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ | | | 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 | int Tcl_CreateAlias( Tcl_Interp *childInterp, /* Interpreter for source command. */ const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ Tcl_Size argc, /* How many additional arguments? */ const char *const *argv) /* These are the additional args. */ { Tcl_Obj *childObjPtr, *targetObjPtr; Tcl_Obj **objv; Tcl_Size i; int result; |
︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 | int Tcl_CreateAliasObj( Tcl_Interp *childInterp, /* Interpreter for source command. */ const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ | | | 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 | int Tcl_CreateAliasObj( Tcl_Interp *childInterp, /* Interpreter for source command. */ const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ Tcl_Size objc, /* How many additional arguments? */ Tcl_Obj *const objv[]) /* Argument vector. */ { Tcl_Obj *childObjPtr, *targetObjPtr; int result; childObjPtr = Tcl_NewStringObj(childCmd, -1); Tcl_IncrRefCount(childObjPtr); |
︙ | ︙ | |||
1453 1454 1455 1456 1457 1458 1459 | Tcl_Interp *interp, /* Interp for error reporting. */ Tcl_Interp *childInterp, /* Interp where alias cmd will live or from * which alias will be deleted. */ Tcl_Interp *parentInterp, /* Interp in which target command will be * invoked. */ Tcl_Obj *namePtr, /* Name of alias cmd. */ Tcl_Obj *targetCmdPtr, /* Name of target cmd. */ | | | 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 | Tcl_Interp *interp, /* Interp for error reporting. */ Tcl_Interp *childInterp, /* Interp where alias cmd will live or from * which alias will be deleted. */ Tcl_Interp *parentInterp, /* Interp in which target command will be * invoked. */ Tcl_Obj *namePtr, /* Name of alias cmd. */ Tcl_Obj *targetCmdPtr, /* Name of target cmd. */ Tcl_Size objc, /* Additional arguments to store */ Tcl_Obj *const objv[]) /* with alias. */ { Alias *aliasPtr; Tcl_HashEntry *hPtr; Target *targetPtr; Child *childPtr; Parent *parentPtr; |
︙ | ︙ | |||
1753 1754 1755 1756 1757 1758 1759 | * forwarded. * *---------------------------------------------------------------------- */ static int AliasNRCmd( | | | 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 | * forwarded. * *---------------------------------------------------------------------- */ static int AliasNRCmd( void *clientData, /* Alias record. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument vector. */ { Alias *aliasPtr = (Alias *)clientData; Tcl_Size prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; |
︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 | } TclSkipTailcall(interp); return Tcl_NREvalObj(interp, listPtr, flags); } int TclAliasObjCmd( | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 | } TclSkipTailcall(interp); return Tcl_NREvalObj(interp, listPtr, flags); } int TclAliasObjCmd( void *clientData, /* Alias record. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument vector. */ { #define ALIAS_CMDV_PREALLOC 10 Alias *aliasPtr = (Alias *)clientData; Tcl_Interp *targetInterp = aliasPtr->targetInterp; |
︙ | ︙ | |||
1898 1899 1900 1901 1902 1903 1904 | } return result; #undef ALIAS_CMDV_PREALLOC } int TclLocalAliasObjCmd( | | | 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 | } return result; #undef ALIAS_CMDV_PREALLOC } int TclLocalAliasObjCmd( void *clientData, /* Alias record. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument vector. */ { #define ALIAS_CMDV_PREALLOC 10 Alias *aliasPtr = (Alias *)clientData; int result; |
︙ | ︙ | |||
1984 1985 1986 1987 1988 1989 1990 | * interpreter. * *---------------------------------------------------------------------- */ static void AliasObjCmdDeleteProc( | | | 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 | * interpreter. * *---------------------------------------------------------------------- */ static void AliasObjCmdDeleteProc( void *clientData) /* The alias record for this alias. */ { Alias *aliasPtr = (Alias *)clientData; Target *targetPtr; Tcl_Size i; Tcl_Obj **objv; Tcl_DecrRefCount(aliasPtr->token); |
︙ | ︙ | |||
2210 2211 2212 2213 2214 2215 2216 | * None. * *---------------------------------------------------------------------- */ int Tcl_GetInterpPath( | | | 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 | * None. * *---------------------------------------------------------------------- */ int Tcl_GetInterpPath( Tcl_Interp *interp, /* Interpreter to start search from. */ Tcl_Interp *targetInterp) /* Interpreter to find. */ { InterpInfo *iiPtr; if (targetInterp == interp) { Tcl_SetObjResult(interp, Tcl_NewObj()); return TCL_OK; |
︙ | ︙ | |||
2312 2313 2314 2315 2316 2317 2318 | *---------------------------------------------------------------------- */ static int ChildBgerror( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ | | | 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 | *---------------------------------------------------------------------- */ static int ChildBgerror( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ Tcl_Size objc, /* Set or Query. */ Tcl_Obj *const objv[]) /* Argument strings. */ { if (objc) { Tcl_Size length; if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { |
︙ | ︙ | |||
2484 2485 2486 2487 2488 2489 2490 | * See user documentation for details. * *---------------------------------------------------------------------- */ int TclChildObjCmd( | | | | 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 | * See user documentation for details. * *---------------------------------------------------------------------- */ int TclChildObjCmd( void *clientData, /* Child interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { return Tcl_NRCallObjProc(interp, NRChildCmd, clientData, objc, objv); } static int NRChildCmd( void *clientData, /* Child interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *childInterp = (Tcl_Interp *)clientData; static const char *const options[] = { "alias", "aliases", "bgerror", "debug", |
︙ | ︙ | |||
2654 2655 2656 2657 2658 2659 2660 | } if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, &limitType) != TCL_OK) { return TCL_ERROR; } switch (limitType) { case LIMIT_TYPE_COMMANDS: | | | 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 | } if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, &limitType) != TCL_OK) { return TCL_ERROR; } switch (limitType) { case LIMIT_TYPE_COMMANDS: return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv); case LIMIT_TYPE_TIME: return ChildTimeLimitCmd(interp, childInterp, 3, objc, objv); } } break; case OPT_MARKTRUSTED: if (objc != 2) { |
︙ | ︙ | |||
2698 2699 2700 2701 2702 2703 2704 | * the child interpreter. * *---------------------------------------------------------------------- */ static void ChildObjCmdDeleteProc( | | | 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 | * the child interpreter. * *---------------------------------------------------------------------- */ static void ChildObjCmdDeleteProc( void *clientData) /* The ChildRecord for the command. */ { Child *childPtr; /* Interim storage for Child record. */ Tcl_Interp *childInterp = (Tcl_Interp *)clientData; /* And for a child interp. */ childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; |
︙ | ︙ | |||
2746 2747 2748 2749 2750 2751 2752 | */ static int ChildDebugCmd( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* The child interpreter in which command * will be evaluated. */ | | | 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 | */ static int ChildDebugCmd( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* The child interpreter in which command * will be evaluated. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const debugTypes[] = { "-frame", NULL }; enum DebugTypes { DEBUG_TYPE_FRAME |
︙ | ︙ | |||
2817 2818 2819 2820 2821 2822 2823 | */ static int ChildEval( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* The child interpreter in which command * will be evaluated. */ | | | 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 | */ static int ChildEval( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* The child interpreter in which command * will be evaluated. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int result; /* * TIP #285: If necessary, reset the cancellation flags for the child * interpreter now; otherwise, canceling a script in a parent interpreter |
︙ | ︙ | |||
2880 2881 2882 2883 2884 2885 2886 | *---------------------------------------------------------------------- */ static int ChildExpose( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ | | | 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 | *---------------------------------------------------------------------- */ static int ChildExpose( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { const char *name; if (Tcl_IsSafe(interp)) { TclSetResult(interp, "permission denied: safe interpreter cannot expose commands"); |
︙ | ︙ | |||
2923 2924 2925 2926 2927 2928 2929 | *---------------------------------------------------------------------- */ static int ChildRecursionLimit( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ | | | 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 | *---------------------------------------------------------------------- */ static int ChildRecursionLimit( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ Tcl_Size objc, /* Set or Query. */ Tcl_Obj *const objv[]) /* Argument strings. */ { Interp *iPtr; Tcl_WideInt limit; if (objc) { if (Tcl_IsSafe(interp)) { |
︙ | ︙ | |||
2983 2984 2985 2986 2987 2988 2989 | *---------------------------------------------------------------------- */ static int ChildHide( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ | | | 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 | *---------------------------------------------------------------------- */ static int ChildHide( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { const char *name; if (Tcl_IsSafe(interp)) { TclSetResult(interp, "permission denied: safe interpreter cannot hide commands"); |
︙ | ︙ | |||
3026 3027 3028 3029 3030 3031 3032 | */ static int ChildHidden( Tcl_Interp *interp, /* Interp for data return. */ Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */ { | | | | | | 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 | */ static int ChildHidden( Tcl_Interp *interp, /* Interp for data return. */ Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */ { Tcl_Obj *listObjPtr; /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ TclNewObj(listObjPtr); hTblPtr = ((Interp *) childInterp)->hiddenCmdTablePtr; if (hTblPtr != NULL) { for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { |
︙ | ︙ | |||
3067 3068 3069 3070 3071 3072 3073 | static int ChildInvokeHidden( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* The child interpreter in which command will * be invoked. */ const char *namespaceName, /* The namespace to use, if any. */ | | | 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 | static int ChildInvokeHidden( Tcl_Interp *interp, /* Interp for error return. */ Tcl_Interp *childInterp, /* The child interpreter in which command will * be invoked. */ const char *namespaceName, /* The namespace to use, if any. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int result; if (Tcl_IsSafe(interp)) { TclSetResult(interp, "not allowed to invoke hidden commands from safe interpreter"); |
︙ | ︙ | |||
4406 4407 4408 4409 4410 4411 4412 | *---------------------------------------------------------------------- */ static int ChildCommandLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Interp *childInterp, /* Interpreter being adjusted. */ | | | | 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 | *---------------------------------------------------------------------- */ static int ChildCommandLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Interp *childInterp, /* Interpreter being adjusted. */ Tcl_Size consumedObjc, /* Number of args already parsed. */ Tcl_Size objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const options[] = { "-command", "-granularity", "-value", NULL }; enum Options { OPT_CMD, OPT_GRAN, OPT_VAL |
︙ | ︙ | |||
4589 4590 4591 4592 4593 4594 4595 | * Depends on the arguments. * *---------------------------------------------------------------------- */ static int ChildTimeLimitCmd( | | | | | | | 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 | * Depends on the arguments. * *---------------------------------------------------------------------- */ static int ChildTimeLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Interp *childInterp, /* Interpreter being adjusted. */ Tcl_Size consumedObjc, /* Number of args already parsed. */ Tcl_Size objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const options[] = { "-command", "-granularity", "-milliseconds", "-seconds", NULL }; enum Options { OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC } index; |
︙ | ︙ |
Changes to generic/tclLink.c.
︙ | ︙ | |||
32 33 34 35 36 37 38 | * needed during trace callbacks, since the * actual variable may be aliased at that time * via upvar. */ void *addr; /* Location of C variable. */ Tcl_Size bytes; /* Size of C variable array. This is 0 when * single variables, and >0 used for array * variables. */ | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | * needed during trace callbacks, since the * actual variable may be aliased at that time * via upvar. */ void *addr; /* Location of C variable. */ Tcl_Size bytes; /* Size of C variable array. This is 0 when * single variables, and >0 used for array * variables. */ Tcl_Size numElems; /* Number of elements in C variable array. * Zero for single variables. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { char c; unsigned char uc; int i; unsigned int ui; |
︙ | ︙ | |||
106 107 108 109 110 111 112 | Tcl_Obj *objPtr); /* * A marker type used to flag weirdnesses so we can pass them around right. */ static Tcl_ObjType invalidRealType = { | | | | | | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | Tcl_Obj *objPtr); /* * A marker type used to flag weirdnesses so we can pass them around right. */ static Tcl_ObjType invalidRealType = { "invalidReal", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; /* * Convenience macro for accessing the value of the C variable pointed to by a * link. Note that this macro produces something that may be regarded as an * lvalue or rvalue; it may be assigned to as well as read. Also note that |
︙ | ︙ | |||
294 295 296 297 298 299 300 | case TCL_LINK_STRING: linkPtr->bytes = size * sizeof(char); size = 1; /* This is a variable length string, no need * to check last value. */ /* * If no address is given create one and use as address the | | | 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 | case TCL_LINK_STRING: linkPtr->bytes = size * sizeof(char); size = 1; /* This is a variable length string, no need * to check last value. */ /* * If no address is given create one and use as address the * not needed linkPtr->lastValue */ if (addr == NULL) { linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes); linkPtr->flags |= LINK_ALLOC_LAST; addr = (char *) &linkPtr->lastValue.cPtr; } |
︙ | ︙ | |||
673 674 675 676 677 678 679 | * modification. * *---------------------------------------------------------------------- */ static char * LinkTraceProc( | | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 | * modification. * *---------------------------------------------------------------------- */ static char * LinkTraceProc( void *clientData, /* Contains information about the link. */ Tcl_Interp *interp, /* Interpreter containing Tcl variable. */ TCL_UNUSED(const char *) /*name1*/, TCL_UNUSED(const char *) /*name2*/, /* Links can only be made to global variables, * so we can find them with need to resolve * caller-supplied name in caller context. */ int flags) /* Miscellaneous additional information. */ |
︙ | ︙ | |||
802 803 804 805 806 807 808 | */ if (linkPtr->flags & LINK_READ_ONLY) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "linked variable is read-only"; } | | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 | */ if (linkPtr->flags & LINK_READ_ONLY) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "linked variable is read-only"; } valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY); if (valueObj == NULL) { /* * This shouldn't ever happen. */ return (char *) "internal error: linked variable couldn't be read"; } |
︙ | ︙ | |||
884 885 886 887 888 889 890 | if (linkPtr->flags & LINK_ALLOC_LAST) { for (i = 0; i < objc; i++) { int *varPtr = &linkPtr->lastValue.iPtr[i]; if (GetInt(objv[i], varPtr)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); | | | 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 | if (linkPtr->flags & LINK_ALLOC_LAST) { for (i = 0; i < objc; i++) { int *varPtr = &linkPtr->lastValue.iPtr[i]; if (GetInt(objv[i], varPtr)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have integer values"; } } } else { int *varPtr = &linkPtr->lastValue.i; if (GetInt(valueObj, varPtr)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, |
︙ | ︙ | |||
952 953 954 955 956 957 958 | if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { int *varPtr = &linkPtr->lastValue.iPtr[i]; if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); | | | | | | 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 | if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { int *varPtr = &linkPtr->lastValue.iPtr[i]; if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have boolean value"; } } } else { int *varPtr = &linkPtr->lastValue.i; if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have boolean value"; } LinkedVar(int) = *varPtr; } break; case TCL_LINK_CHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have char value"; } linkPtr->lastValue.cPtr[i] = (char) valueInt; } } else { if (GetInt(valueObj, &valueInt) || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have char value"; } LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt; } break; case TCL_LINK_UCHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(0, valueInt, (int)UCHAR_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have unsigned char value"; } linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt; } |
︙ | ︙ | |||
1020 1021 1022 1023 1024 1025 1026 | case TCL_LINK_SHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); | | | | | 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 | case TCL_LINK_SHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have short value"; } linkPtr->lastValue.sPtr[i] = (short) valueInt; } } else { if (GetInt(valueObj, &valueInt) || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have short value"; } LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt; } break; case TCL_LINK_USHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(0, valueInt, (int)USHRT_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have unsigned short value"; } linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt; } } else { if (GetInt(valueObj, &valueInt) || !InRange(0, valueInt, (int)USHRT_MAX)) { |
︙ | ︙ | |||
1066 1067 1068 1069 1070 1071 1072 | case TCL_LINK_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide) || !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); | | | 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 | case TCL_LINK_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide) || !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have unsigned int value"; } linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide; } } else { if (GetWide(valueObj, &valueWide) || !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) { |
︙ | ︙ | |||
1088 1089 1090 1091 1092 1093 1094 | break; case TCL_LINK_WIDE_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetUWide(objv[i], &valueUWide)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); | | | | | 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 | break; case TCL_LINK_WIDE_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetUWide(objv[i], &valueUWide)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have unsigned wide int value"; } linkPtr->lastValue.uwPtr[i] = valueUWide; } } else { if (GetUWide(valueObj, &valueUWide)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned wide int value"; } LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide; } break; case TCL_LINK_FLOAT: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetDouble(objv[i], &valueDouble) && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) && !IsSpecial(valueDouble)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have float value"; } linkPtr->lastValue.fPtr[i] = (float) valueDouble; } } else { if (GetDouble(valueObj, &valueDouble) && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) && !IsSpecial(valueDouble)) { |
︙ | ︙ |
Changes to generic/tclListObj.c.
︙ | ︙ | |||
35 36 37 38 39 40 41 | # ifndef NDEBUG # define ENABLE_LIST_ASSERTS /* Always activate list asserts in debug mode */ # endif #endif #ifdef ENABLE_LIST_ASSERTS | | | | | | | | | | | | | | | | < | | 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 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 | # ifndef NDEBUG # define ENABLE_LIST_ASSERTS /* Always activate list asserts in debug mode */ # endif #endif #ifdef ENABLE_LIST_ASSERTS #define LIST_ASSERT(cond_) assert(cond_) /* * LIST_INDEX_ASSERT is to catch errors with negative indices and counts * being passed AFTER validation. On Tcl9 length types are unsigned hence * the checks against LIST_MAX. On Tcl8 length types are signed hence the * also checks against 0. */ #define LIST_INDEX_ASSERT(idxarg_) \ do { \ Tcl_Size idx_ = (idxarg_); /* To guard against ++ etc. */ \ LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \ } while (0) /* Ditto for counts except upper limit is different */ #define LIST_COUNT_ASSERT(countarg_) \ do { \ Tcl_Size count_ = (countarg_); /* To guard against ++ etc. */ \ LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX); \ } while (0) #else #define LIST_ASSERT(cond_) ((void) 0) #define LIST_INDEX_ASSERT(idx_) ((void) 0) #define LIST_COUNT_ASSERT(count_) ((void) 0) #endif /* Checks for when caller should have already converted to internal list type */ #define LIST_ASSERT_TYPE(listObj_) \ LIST_ASSERT(TclHasInternalRep((listObj_), &tclListType)) /* * If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the * command line), the entire list internal representation is checked for * inconsistencies. This has a non-trivial cost so has to be separately * enabled and not part of assertions checking. However, the test suite does * invoke ListRepValidate directly even without ENABLE_LIST_INVARIANTS. */ #ifdef ENABLE_LIST_INVARIANTS #define LISTREP_CHECK(listRepPtr_) ListRepValidate(listRepPtr_, __FILE__, __LINE__) #else #define LISTREP_CHECK(listRepPtr_) (void) 0 #endif /* * Flags used for controlling behavior of allocation of list * internal representations. * * If the LISTREP_PANIC_ON_FAIL bit is set, the function will panic if |
︙ | ︙ | |||
108 109 110 111 112 113 114 | */ #define LISTREP_PANIC_ON_FAIL 0x00000001 #define LISTREP_SPACE_FAVOR_FRONT 0x00000002 #define LISTREP_SPACE_FAVOR_BACK 0x00000004 #define LISTREP_SPACE_ONLY_BACK 0x00000008 #define LISTREP_SPACE_FAVOR_NONE \ (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK) | | | | | < | < | | > > | < | | < | | | | | | < | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | 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 247 248 249 250 | */ #define LISTREP_PANIC_ON_FAIL 0x00000001 #define LISTREP_SPACE_FAVOR_FRONT 0x00000002 #define LISTREP_SPACE_FAVOR_BACK 0x00000004 #define LISTREP_SPACE_ONLY_BACK 0x00000008 #define LISTREP_SPACE_FAVOR_NONE \ (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK) #define LISTREP_SPACE_FLAGS \ (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \ | LISTREP_SPACE_ONLY_BACK) /* * Prototypes for non-inline static functions defined later in this file: */ static int MemoryAllocationError(Tcl_Interp *, size_t size); static int ListLimitExceededError(Tcl_Interp *); static ListStore *ListStoreNew(Tcl_Size objc, Tcl_Obj *const objv[], int flags); static int ListRepInit(Tcl_Size objc, Tcl_Obj *const objv[], int flags, ListRep *); static int ListRepInitAttempt(Tcl_Interp *, Tcl_Size objc, Tcl_Obj *const objv[], ListRep *); static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags); static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr); static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr); static void ListRepRange(ListRep *srcRepPtr, Tcl_Size rangeStart, Tcl_Size rangeEnd, int preserveSrcRep, ListRep *rangeRepPtr); static ListStore *ListStoreReallocate(ListStore *storePtr, Tcl_Size numSlots); static void ListRepValidate(const ListRep *repPtr, const char *file, int lineNum); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfList(Tcl_Obj *listPtr); static Tcl_Size ListLength(Tcl_Obj *listPtr); /* * The structure below defines the list Tcl object type by means of functions * that can be invoked by generic object code. * * The internal representation of a list object is ListRep defined in tcl.h. */ const Tcl_ObjType tclListType = { "list", /* name */ FreeListInternalRep, /* freeIntRepProc */ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ SetListFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V1(ListLength) }; /* Macros to manipulate the List internal rep */ #define ListRepIncrRefs(repPtr_) \ do { \ (repPtr_)->storePtr->refCount++; \ if ((repPtr_)->spanPtr) { \ (repPtr_)->spanPtr->refCount++; \ } \ } while (0) /* Returns number of free unused slots at the back of the ListRep's ListStore */ #define ListRepNumFreeTail(repPtr_) \ ((repPtr_)->storePtr->numAllocated \ - ((repPtr_)->storePtr->firstUsed + (repPtr_)->storePtr->numUsed)) /* Returns number of free unused slots at the front of the ListRep's ListStore */ #define ListRepNumFreeHead(repPtr_) ((repPtr_)->storePtr->firstUsed) /* Returns a pointer to the slot corresponding to list index listIdx_ */ #define ListRepSlotPtr(repPtr_, listIdx_) \ (&(repPtr_)->storePtr->slots[ListRepStart(repPtr_) + (listIdx_)]) /* * Macros to replace the internal representation in a Tcl_Obj. There are * subtle differences in each so make sure to use the right one to avoid * memory leaks, access to freed memory and the like. * * ListObjStompRep - assumes the Tcl_Obj internal representation can be * overwritten AND that the passed ListRep already has reference counts that * include the reference from the Tcl_Obj. Basically just copies the pointers * and sets the internal Tcl_Obj type to list * * ListObjOverwriteRep - like ListObjOverwriteRep but additionally * increments reference counts on the passed ListRep. Generally used when * the string representation of the Tcl_Obj is not to be modified. * * ListObjReplaceRepAndInvalidate - Like ListObjOverwriteRep but additionally * assumes the Tcl_Obj internal rep is valid (and possibly even same as * passed ListRep) and frees it first. Additionally invalidates the string * representation. Generally used when modifying a Tcl_Obj value. */ #define ListObjStompRep(objPtr_, repPtr_) \ do { \ (objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \ (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \ (objPtr_)->typePtr = &tclListType; \ } while (0) #define ListObjOverwriteRep(objPtr_, repPtr_) \ do { \ ListRepIncrRefs(repPtr_); \ ListObjStompRep(objPtr_, repPtr_); \ } while (0) #define ListObjReplaceRepAndInvalidate(objPtr_, repPtr_) \ do { \ /* Note order important, don't use ListObjOverwriteRep! */ \ ListRepIncrRefs(repPtr_); \ TclFreeInternalRep(objPtr_); \ TclInvalidateStringRep(objPtr_); \ ListObjStompRep(objPtr_, repPtr_); \ } while (0) /* *------------------------------------------------------------------------ * * ListSpanNew -- * * Allocates and initializes memory for a new ListSpan. The reference * count on the returned struct is 0. * * Results: * Non-NULL pointer to the allocated ListSpan. * * Side effects: * The function will panic on memory allocation failure. * *------------------------------------------------------------------------ */ static inline ListSpan * ListSpanNew( Tcl_Size firstSlot, /* Starting slot index of the span */ Tcl_Size numSlots) /* Number of slots covered by the span */ { ListSpan *spanPtr = (ListSpan *) Tcl_Alloc(sizeof(*spanPtr)); spanPtr->refCount = 0; spanPtr->spanStart = firstSlot; spanPtr->spanLength = numSlots; return spanPtr; } |
︙ | ︙ | |||
267 268 269 270 271 272 273 | * * Side effects: * The memory may be freed. * *------------------------------------------------------------------------ */ static inline void | | < | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 | * * Side effects: * The memory may be freed. * *------------------------------------------------------------------------ */ static inline void ListSpanDecrRefs(ListSpan *spanPtr) { if (spanPtr->refCount <= 1) { Tcl_Free(spanPtr); } else { spanPtr->refCount -= 1; } } |
︙ | ︙ | |||
299 300 301 302 303 304 305 | * Side effects: * None. * *------------------------------------------------------------------------ */ static inline int ListSpanMerited( | | | | < | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | * Side effects: * None. * *------------------------------------------------------------------------ */ static inline int ListSpanMerited( Tcl_Size length, /* Length of the proposed span */ Tcl_Size usedStorageLength, /* Number of slots currently in used */ Tcl_Size allocatedStorageLength) /* Length of the currently allocation */ { /* * Possible optimizations for future consideration * - heuristic LIST_SPAN_THRESHOLD * - currently, information about the sharing (ref count) of existing * storage is not passed. Perhaps it should be. For example if the * existing storage has a "large" ref count, then it might make sense |
︙ | ︙ | |||
346 347 348 349 350 351 352 | * * Side effects: * See comments for ListRepUnsharedFreeUnreferenced. * *------------------------------------------------------------------------ */ static inline void | | < | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 | * * Side effects: * See comments for ListRepUnsharedFreeUnreferenced. * *------------------------------------------------------------------------ */ static inline void ListRepFreeUnreferenced(const ListRep *repPtr) { if (! ListRepIsShared(repPtr) && repPtr->spanPtr) { /* T:listrep-1.5.1 */ ListRepUnsharedFreeUnreferenced(repPtr); } } |
︙ | ︙ | |||
372 373 374 375 376 377 378 | * Side effects: * As above. * *------------------------------------------------------------------------ */ static inline void ObjArrayIncrRefs( | | | | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 | * Side effects: * As above. * *------------------------------------------------------------------------ */ static inline void ObjArrayIncrRefs( Tcl_Obj * const *objv, /* Pointer to the array */ Tcl_Size startIdx, /* Starting index of subarray within objv */ Tcl_Size count) /* Number of elements in the subarray */ { Tcl_Obj *const *end; LIST_INDEX_ASSERT(startIdx); LIST_COUNT_ASSERT(count); objv += startIdx; end = objv + count; while (objv < end) { |
︙ | ︙ | |||
404 405 406 407 408 409 410 | * Side effects: * As above. * *------------------------------------------------------------------------ */ static inline void ObjArrayDecrRefs( | | | | | 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 | * Side effects: * As above. * *------------------------------------------------------------------------ */ static inline void ObjArrayDecrRefs( Tcl_Obj * const *objv, /* Pointer to the array */ Tcl_Size startIdx, /* Starting index of subarray within objv */ Tcl_Size count) /* Number of elements in the subarray */ { Tcl_Obj * const *end; LIST_INDEX_ASSERT(startIdx); LIST_COUNT_ASSERT(count); objv += startIdx; end = objv + count; while (objv < end) { |
︙ | ︙ | |||
436 437 438 439 440 441 442 | * Side effects: * Reference counts on copied Tcl_Obj's are incremented. * *------------------------------------------------------------------------ */ static inline void ObjArrayCopy( | | | | | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 | * Side effects: * Reference counts on copied Tcl_Obj's are incremented. * *------------------------------------------------------------------------ */ static inline void ObjArrayCopy( Tcl_Obj **to, /* Destination */ Tcl_Size count, /* Number of pointers to copy */ Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */ { Tcl_Obj **end; LIST_COUNT_ASSERT(count); end = to + count; /* TODO - would memmove followed by separate IncrRef loop be faster? */ while (to < end) { Tcl_IncrRefCount(*from); |
︙ | ︙ | |||
467 468 469 470 471 472 473 | * Side effects: * Error message and code are stored in the interpreter if not NULL. * *------------------------------------------------------------------------ */ static int MemoryAllocationError( | | | | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 | * Side effects: * Error message and code are stored in the interpreter if not NULL. * *------------------------------------------------------------------------ */ static int MemoryAllocationError( Tcl_Interp *interp, /* Interpreter for error message. May be NULL */ size_t size) /* Size of attempted allocation that failed */ { if (interp != NULL) { TclPrintfResult(interp, "list construction failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", size); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); |
︙ | ︙ | |||
496 497 498 499 500 501 502 | * * Side effects: * Error message and code are stored in the interpreter if not NULL. * *------------------------------------------------------------------------ */ static int | | < | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 | * * Side effects: * Error message and code are stored in the interpreter if not NULL. * *------------------------------------------------------------------------ */ static int ListLimitExceededError(Tcl_Interp *interp) { if (interp != NULL) { TclSetResult(interp, "max length of a Tcl list exceeded"); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return TCL_ERROR; } |
︙ | ︙ | |||
526 527 528 529 530 531 532 | * Side effects: * The contents of the ListRep's ListStore area are shifted down in the * storage area. The ListRep's ListSpan is updated accordingly. * *------------------------------------------------------------------------ */ static inline void | | < < | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 | * Side effects: * The contents of the ListRep's ListStore area are shifted down in the * storage area. The ListRep's ListSpan is updated accordingly. * *------------------------------------------------------------------------ */ static inline void ListRepUnsharedShiftDown(ListRep *repPtr, Tcl_Size shiftCount) { ListStore *storePtr; LISTREP_CHECK(repPtr); LIST_ASSERT(!ListRepIsShared(repPtr)); storePtr = repPtr->storePtr; |
︙ | ︙ | |||
583 584 585 586 587 588 589 | * The contents of the ListRep's ListStore area are shifted up in the * storage area. The ListRep's ListSpan is updated accordingly. * *------------------------------------------------------------------------ */ #if 0 static inline void | | < < | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 | * The contents of the ListRep's ListStore area are shifted up in the * storage area. The ListRep's ListSpan is updated accordingly. * *------------------------------------------------------------------------ */ #if 0 static inline void ListRepUnsharedShiftUp(ListRep *repPtr, Tcl_Size shiftCount) { ListStore *storePtr; LISTREP_CHECK(repPtr); LIST_ASSERT(!ListRepIsShared(repPtr)); LIST_COUNT_ASSERT(shiftCount); |
︙ | ︙ | |||
631 632 633 634 635 636 637 | * * Side effects: * Panics if any invariant is not met. * *------------------------------------------------------------------------ */ static void | | < < < | | | | | | | 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 | * * Side effects: * Panics if any invariant is not met. * *------------------------------------------------------------------------ */ static void ListRepValidate(const ListRep *repPtr, const char *file, int lineNum) { ListStore *storePtr = repPtr->storePtr; const char *condition; (void)storePtr; /* To stop gcc from whining about unused vars */ #define INVARIANT(cond_) \ do { \ if (!(cond_)) { \ condition = #cond_; \ goto failure; \ } \ } while (0) /* Separate each condition so line number gives exact reason for failure */ INVARIANT(storePtr != NULL); INVARIANT(storePtr->numAllocated >= 0); INVARIANT(storePtr->numAllocated <= LIST_MAX); INVARIANT(storePtr->firstUsed >= 0); |
︙ | ︙ | |||
677 678 679 680 681 682 683 | #undef INVARIANT return; failure: Tcl_Panic("List internal failure in %s line %d. Condition: %s", | > > | | < < | | | | | | | 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 | #undef INVARIANT return; failure: Tcl_Panic("List internal failure in %s line %d. Condition: %s", file, lineNum, condition); } /* *------------------------------------------------------------------------ * * TclListObjValidate -- * * Wrapper around ListRepValidate. Primarily used from test suite. * * Results: * None. * * Side effects: * Will panic if internal structure is not consistent or if object * cannot be converted to a list object. * *------------------------------------------------------------------------ */ void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj) { ListRep listRep; if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { Tcl_Panic("Object passed to TclListObjValidate cannot be converted to " "a list object."); } ListRepValidate(&listRep, __FILE__, __LINE__); } /* *---------------------------------------------------------------------- * * ListStoreNew -- * * Allocates a new ListStore with space for at least objc elements. objc * must be > 0. If objv!=NULL, initializes with the first objc values * in that array. If objv==NULL, initalize 0 elements, with space * to add objc more. * * Normally the function allocates the exact space requested unless * the flags arguments has any LISTREP_SPACE_* * bits set. See the comments for those #defines. * * Results: * On success, a pointer to the allocated ListStore is returned. * On allocation failure, panics if LISTREP_PANIC_ON_FAIL is set in * flags; otherwise returns NULL. * * Side effects: * The ref counts of the elements in objv are incremented on success * since the returned ListStore references them. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
850 851 852 853 854 855 856 | } /* *---------------------------------------------------------------------- * * ListRepInit -- * | | | | | | | | | | 834 835 836 837 838 839 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 | } /* *---------------------------------------------------------------------- * * ListRepInit -- * * Initializes a ListRep to hold a list internal representation * with space for objc elements. * * objc must be > 0. If objv!=NULL, initializes with the first objc * values in that array. If objv==NULL, initalize list internal rep to * have 0 elements, with space to add objc more. * * Normally the function allocates the exact space requested unless * the flags arguments has one of the LISTREP_SPACE_* bits set. * See the comments for those #defines. * * The reference counts of the ListStore and ListSpan (if present) * pointed to by the initialized repPtr are set to zero. * Caller has to manage them as necessary. * * Results: * On success, TCL_OK is returned with *listRepPtr initialized. * On failure, panics if LISTREP_PANIC_ON_FAIL is set in flags; otherwise * returns TCL_ERROR with *listRepPtr fields set to NULL. * * Side effects: * The ref counts of the elements in objv are incremented since the * resulting list now refers to them. * *---------------------------------------------------------------------- |
︙ | ︙ | |||
915 916 917 918 919 920 921 | * ListRepInitAttempt -- * * Creates a list internal rep with space for objc elements. See * ListRepInit for requirements for parameters (in particular objc must * be > 0). This function only adds error messages to the interpreter if * not NULL. * | | | | 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 | * ListRepInitAttempt -- * * Creates a list internal rep with space for objc elements. See * ListRepInit for requirements for parameters (in particular objc must * be > 0). This function only adds error messages to the interpreter if * not NULL. * * The reference counts of the ListStore and ListSpan (if present) * pointed to by the initialized repPtr are set to zero. * Caller has to manage them as necessary. * * Results: * On success, TCL_OK is returned with *listRepPtr initialized. * On allocation failure, returnes TCL_ERROR with an error message * in the interpreter if non-NULL. * * Side effects: * The ref counts of the elements in objv are incremented since the * resulting list now refers to them. * |
︙ | ︙ | |||
1251 1252 1253 1254 1255 1256 1257 | * refer to a list object and the object can not be converted to one, * TCL_ERROR is returned and an error message will be left in the * interpreter's result if interp is not NULL. * * Side effects: * The possible conversion of the object referenced by listPtr * to a list object. *repPtr is initialized to the internal rep | | | | | | | 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 | * refer to a list object and the object can not be converted to one, * TCL_ERROR is returned and an error message will be left in the * interpreter's result if interp is not NULL. * * Side effects: * The possible conversion of the object referenced by listPtr * to a list object. *repPtr is initialized to the internal rep * if result is TCL_OK, or set to NULL on error. *---------------------------------------------------------------------- */ static int TclListObjGetRep( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object for which an element array is * to be returned. */ ListRep *repPtr) /* Location to store descriptor */ { if (!TclHasInternalRep(listObj, &tclListType)) { int result; result = SetListFromAny(interp, listObj); if (result != TCL_OK) { /* Init to keep gcc happy wrt uninitialized fields at call site */ repPtr->storePtr = NULL; |
︙ | ︙ | |||
1383 1384 1385 1386 1387 1388 1389 | * Initializes a ListRep as a range within the passed ListRep. * The range limits are clamped to the list boundaries. * * Results: * None. * * Side effects: | | | | | | | | | | | | | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 | * Initializes a ListRep as a range within the passed ListRep. * The range limits are clamped to the list boundaries. * * Results: * None. * * Side effects: * The ListStore and ListSpan referenced by in the returned ListRep * may or may not be the same as those passed in. For example, the * ListStore may differ because the range is small enough that a new * ListStore is more memory-optimal. The ListSpan may differ because * it is NULL or shared. Regardless, reference counts on the returned * values are not incremented. Generally, ListObjReplaceRepAndInvalidate * may be used to store the new ListRep back into an object or a * ListRepIncrRefs followed by ListRepDecrRefs to free in case of errors. * Any other use should be carefully reconsidered. * TODO WARNING:- this is an awkward interface and easy for caller * to get wrong. Mostly due to refcount combinations. Perhaps passing * in the source listObj instead of source listRep might simplify. * *------------------------------------------------------------------------ */ static void ListRepRange( ListRep *srcRepPtr, /* Contains source of the range */ Tcl_Size rangeStart, /* Index of first element to include */ |
︙ | ︙ | |||
1539 1540 1541 1542 1543 1544 1545 | /* Assert: Because numSrcElems > rangeEnd earlier */ if (numAfterRangeEnd != 0) { /* T:listrep-3.17 */ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); } memmove(&srcRepPtr->storePtr->slots[0], &srcRepPtr->storePtr | | | 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 | /* Assert: Because numSrcElems > rangeEnd earlier */ if (numAfterRangeEnd != 0) { /* T:listrep-3.17 */ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); } memmove(&srcRepPtr->storePtr->slots[0], &srcRepPtr->storePtr ->slots[srcRepPtr->storePtr->firstUsed + rangeStart], rangeLen * sizeof(Tcl_Obj *)); srcRepPtr->storePtr->firstUsed = 0; srcRepPtr->storePtr->numUsed = rangeLen; srcRepPtr->storePtr->flags = 0; if (srcRepPtr->spanPtr) { /* In case the source has a span, update it for consistency */ /* T:listrep-3.{15,17} */ |
︙ | ︙ | |||
1567 1568 1569 1570 1571 1572 1573 | /* *---------------------------------------------------------------------- * * TclListObjRange -- * * Makes a slice of a list value. | | | | 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 | /* *---------------------------------------------------------------------- * * TclListObjRange -- * * Makes a slice of a list value. * *listObj must be known to be a valid list. * * Results: * Returns a pointer to the sliced list. * This may be a new object or the same object if not shared. * Returns NULL if passed listObj was not a list and could not be * converted to one. * * Side effects: * The possible conversion of the object referenced by listPtr * to a list object. * |
︙ | ︙ | |||
1736 1737 1738 1739 1740 1741 1742 | } /* *------------------------------------------------------------------------ * * TclListObjAppendElements -- * | | | | | 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 | } /* *------------------------------------------------------------------------ * * TclListObjAppendElements -- * * Appends multiple elements to a Tcl_Obj list object. If * the passed Tcl_Obj is not a list object, it will be converted to one * and an error raised if the conversion fails. * * The Tcl_Obj must not be shared though the internal representation * may be. * * Results: * On success, TCL_OK is returned with the specified elements appended. * On failure, TCL_ERROR is returned with an error message in the |
︙ | ︙ | |||
1968 1969 1970 1971 1972 1973 1974 | /* Empty string => empty list. Avoid unnecessary shimmering */ if (listObj->bytes == &tclEmptyString) { *objPtrPtr = NULL; return TCL_OK; } | | | 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 | /* Empty string => empty list. Avoid unnecessary shimmering */ if (listObj->bytes == &tclEmptyString) { *objPtrPtr = NULL; return TCL_OK; } int hasAbstractList = TclObjTypeHasProc(listObj,indexProc) != 0; if (hasAbstractList) { return TclObjTypeIndex(interp, listObj, index, objPtrPtr); } if (TclListObjGetElements(interp, listObj, &numElems, &elemObjs) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ | |||
2010 2011 2012 2013 2014 2015 2016 | * *---------------------------------------------------------------------- */ #undef Tcl_ListObjLength int Tcl_ListObjLength( | | | | | 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 | * *---------------------------------------------------------------------- */ #undef Tcl_ListObjLength int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object whose #elements to return. */ Tcl_Size *lenPtr) /* The resulting length is stored here. */ { ListRep listRep; /* Empty string => empty list. Avoid unnecessary shimmering */ if (listObj->bytes == &tclEmptyString) { *lenPtr = 0; return TCL_OK; |
︙ | ︙ | |||
2751 2752 2753 2754 2755 2756 2757 | /* *---------------------------------------------------------------------- * * TclLsetList -- * * Core of the 'lset' command when objc == 4. Objv[2] may be either a * scalar index or a list of indices. | | | 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 | /* *---------------------------------------------------------------------- * * TclLsetList -- * * Core of the 'lset' command when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * It also handles 'lpop' when given a NULL value. * * Results: * Returns the new value of the list variable, or NULL if there was an * error. The returned object includes one reference count for the * pointer returned. * * Side effects: |
︙ | ︙ | |||
2777 2778 2779 2780 2781 2782 2783 | Tcl_Obj * TclLsetList( Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listObj, /* Pointer to the list being modified. */ Tcl_Obj *indexArgObj, /* Index or index-list arg to 'lset'. */ Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */ { | | | | 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 | Tcl_Obj * TclLsetList( Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listObj, /* Pointer to the list being modified. */ Tcl_Obj *indexArgObj, /* Index or index-list arg to 'lset'. */ Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */ { Tcl_Size indexCount = 0; /* Number of indices in the index list. */ Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */ Tcl_Obj *retValueObj; /* Pointer to the list to be returned. */ Tcl_Size index; /* Current index in the list - discarded. */ Tcl_Obj *indexListCopy; /* * Determine whether the index arg designates a list or a single index. * We have to be careful about the order of the checks to avoid repeated * shimmering; see TIP #22 and #23 for details. */ |
︙ | ︙ | |||
2807 2808 2809 2810 2811 2812 2813 | /* indexArgPtr designates a single index. */ /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } } else { | | | 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 | /* indexArgPtr designates a single index. */ /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } } else { indexListCopy = TclListObjCopy(NULL,indexArgObj); if (!indexListCopy) { /* * indexArgPtr designates something that is neither an index nor a * well formed list. Report the error via TclLsetFlat. */ retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } else { |
︙ | ︙ | |||
2846 2847 2848 2849 2850 2851 2852 | /* *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. | | | 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 | /* *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. * It also handles 'lpop' when given a NULL value. * * Results: * Returns the new value of the list variable, or NULL if an error * occurred. The returned object includes one reference count for the * pointer returned. * * Side effects: |
︙ | ︙ | |||
2967 2968 2969 2970 2971 2972 2973 | /* ...the index we're trying to use isn't an index at all. */ result = TCL_ERROR; indexArray++; /* Why bother with this increment? TBD */ break; } indexArray++; | | | | | | | 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 | /* ...the index we're trying to use isn't an index at all. */ result = TCL_ERROR; indexArray++; /* Why bother with this increment? TBD */ break; } indexArray++; /* * Special case 0-length lists. The Tcl indexing function treat * will return any value beyond length as TCL_SIZE_MAX for this * case. */ if ((index == TCL_SIZE_MAX) && (elemCount == 0)) { index = 0; } if (index < 0 || index > elemCount || (valueObj == NULL && index >= elemCount)) { /* ...the index points outside the sublist. */ if (interp != NULL) { |
︙ | ︙ | |||
3153 3154 3155 3156 3157 3158 3159 | Tcl_Obj *listObj, /* List object in which element should be * stored. */ Tcl_Size index, /* Index of element to store. */ Tcl_Obj *valueObj) /* Tcl object to store in the designated list * element. */ { ListRep listRep; | | | 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 | Tcl_Obj *listObj, /* List object in which element should be * stored. */ Tcl_Size index, /* Index of element to store. */ Tcl_Obj *valueObj) /* Tcl object to store in the designated list * element. */ { ListRep listRep; Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */ Tcl_Size elemCount; /* Number of elements in the list. */ /* Ensure that the listObj parameter designates an unshared list. */ if (Tcl_IsShared(listObj)) { Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } |
︙ | ︙ | |||
3345 3346 3347 3348 3349 3350 3351 | while (!done) { *elemPtrs++ = keyPtr; *elemPtrs++ = valuePtr; Tcl_IncrRefCount(keyPtr); Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } | | | 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 | while (!done) { *elemPtrs++ = keyPtr; *elemPtrs++ = valuePtr; Tcl_IncrRefCount(keyPtr); Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } } else if (TclObjTypeHasProc(objPtr,indexProc)) { Tcl_Size elemCount, i; elemCount = TclObjTypeLength(objPtr); if (ListRepInitAttempt(interp, elemCount, NULL, &listRep) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ |
Changes to generic/tclLiteral.c.
︙ | ︙ | |||
54 55 56 57 58 59 60 | * The literal table is made ready for use. * *---------------------------------------------------------------------- */ void TclInitLiteralTable( | | > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | * The literal table is made ready for use. * *---------------------------------------------------------------------- */ void TclInitLiteralTable( LiteralTable *tablePtr) /* Pointer to table structure, which is * supplied by the caller. */ { #if (TCL_SMALL_HASH_TABLE != 4) Tcl_Panic("%s: TCL_SMALL_HASH_TABLE is %d, not 4", "TclInitLiteralTable", TCL_SMALL_HASH_TABLE); #endif |
︙ | ︙ | |||
171 172 173 174 175 176 177 | * *---------------------------------------------------------------------- */ Tcl_Obj * TclCreateLiteral( Interp *iPtr, | | | | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | * *---------------------------------------------------------------------- */ Tcl_Obj * TclCreateLiteral( Interp *iPtr, const char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ Tcl_Size length, /* Number of bytes in the string. */ size_t hash, /* The string's hash. If the value is * TCL_INDEX_NONE, it will be computed here. */ int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr) { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; |
︙ | ︙ | |||
384 385 386 387 388 389 390 | * buffer holding the result of backslash substitutions. * *---------------------------------------------------------------------- */ int /* Do NOT change this type. Should not be wider than TclEmitPush operand*/ TclRegisterLiteral( | | | | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 | * buffer holding the result of backslash substitutions. * *---------------------------------------------------------------------- */ int /* Do NOT change this type. Should not be wider than TclEmitPush operand*/ TclRegisterLiteral( void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ const char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ Tcl_Size length, /* Number of bytes in the string. If -1, the * string consists of all bytes up to the * first null character. */ int flags) /* If LITERAL_ON_HEAP then the caller already * malloc'd bytes and ownership is passed to * this function. If LITERAL_CMD_NAME then * the literal should not be shared across * namespaces. */ |
︙ | ︙ | |||
502 503 504 505 506 507 508 | *---------------------------------------------------------------------- */ static LiteralEntry * LookupLiteralEntry( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ | | | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 | *---------------------------------------------------------------------- */ static LiteralEntry * LookupLiteralEntry( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal * that was previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *entryPtr; const char *bytes; |
︙ | ︙ | |||
548 549 550 551 552 553 554 | *---------------------------------------------------------------------- */ void TclHideLiteral( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ | | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 | *---------------------------------------------------------------------- */ void TclHideLiteral( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ CompileEnv *envPtr,/* Points to CompileEnv whose literal array * contains the entry being hidden. */ int index) /* The index of the entry in the literal * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; size_t localHash; |
︙ | ︙ | |||
612 613 614 615 616 617 618 | * literal object. * *---------------------------------------------------------------------- */ int TclAddLiteralObj( | | | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 | * literal object. * *---------------------------------------------------------------------- */ int TclAddLiteralObj( CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ Tcl_Obj *objPtr, /* The object to insert into the array. */ LiteralEntry **litPtrPtr) /* The location where the pointer to the new * literal entry should be stored. May be * NULL. */ { LiteralEntry *lPtr; |
︙ | ︙ | |||
665 666 667 668 669 670 671 | * array of the CompileEnv's literal array if it becomes too large. * *---------------------------------------------------------------------- */ static size_t AddLocalLiteralEntry( | | | 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 | * array of the CompileEnv's literal array if it becomes too large. * *---------------------------------------------------------------------- */ static size_t AddLocalLiteralEntry( CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ int localHash) /* Hash value for the literal's string. */ { LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; size_t objIndex; |
︙ | ︙ | |||
743 744 745 746 747 748 749 | * The local literal table is updated to refer to the new entries. * *---------------------------------------------------------------------- */ static void ExpandLocalLiteralArray( | | | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 | * The local literal table is updated to refer to the new entries. * *---------------------------------------------------------------------- */ static void ExpandLocalLiteralArray( CompileEnv *envPtr)/* Points to the CompileEnv whose object array * must be enlarged. */ { /* * The current allocated local literal entries are stored between elements * 0 and (envPtr->literalArrayNext - 1) [inclusive]. */ |
︙ | ︙ | |||
825 826 827 828 829 830 831 | *---------------------------------------------------------------------- */ void TclReleaseLiteral( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ | | | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 | *---------------------------------------------------------------------- */ void TclReleaseLiteral( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ Tcl_Obj *objPtr) /* Points to a literal object that was * previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr; LiteralEntry *entryPtr, *prevPtr; const char *bytes; |
︙ | ︙ | |||
905 906 907 908 909 910 911 | * None. * *---------------------------------------------------------------------- */ static size_t HashString( | | | | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 | * None. * *---------------------------------------------------------------------- */ static size_t HashString( const char *string, /* String for which to compute hash value. */ size_t length) /* Number of bytes in the string. */ { size_t result = 0; /* * I tried a zillion different hash functions and asked many other people * for advice. Many people had their own favorite functions, all * different, but no-one had much idea why they were good ones. I chose |
︙ | ︙ | |||
969 970 971 972 973 974 975 | * Memory gets reallocated and entries get rehashed into new buckets. * *---------------------------------------------------------------------- */ static void RebuildLiteralTable( | | > | 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 | * Memory gets reallocated and entries get rehashed into new buckets. * *---------------------------------------------------------------------- */ static void RebuildLiteralTable( LiteralTable *tablePtr) /* Local or global table to enlarge. */ { LiteralEntry **oldBuckets; LiteralEntry **oldChainPtr, **newChainPtr; LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; size_t oldSize, count, index; |
︙ | ︙ |
Changes to generic/tclLoad.c.
︙ | ︙ | |||
152 153 154 155 156 157 158 | if (TclGetString(objv[1])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } | | < | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | if (TclGetString(objv[1])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } ++objv; --objc; if (LOAD_GLOBAL == index) { flags |= TCL_LOAD_GLOBAL; } else if (LOAD_LAZY == index) { flags |= TCL_LOAD_LAZY; } else { break; } |
︙ | ︙ | |||
988 989 990 991 992 993 994 | void Tcl_StaticLibrary( Tcl_Interp *interp, /* If not NULL, it means that the library has * already been loaded into the given * interpreter by calling the appropriate init * proc. */ | | | 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 | void Tcl_StaticLibrary( Tcl_Interp *interp, /* If not NULL, it means that the library has * already been loaded into the given * interpreter by calling the appropriate init * proc. */ const char *prefix, /* Prefix. */ Tcl_LibraryInitProc *initProc, /* Function to call to incorporate this * library into a trusted interpreter. */ Tcl_LibraryInitProc *safeInitProc) /* Function to call to incorporate this * library into a safe interpreter (one that * will execute untrusted scripts). NULL means |
︙ | ︙ | |||
1180 1181 1182 1183 1184 1185 1186 | * Storage for all of the InterpLibrary functions for interp get deleted. * *---------------------------------------------------------------------- */ static void LoadCleanupProc( | | | | 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 | * Storage for all of the InterpLibrary functions for interp get deleted. * *---------------------------------------------------------------------- */ static void LoadCleanupProc( TCL_UNUSED(void *), /* Pointer to first InterpLibrary structure * for interp. */ Tcl_Interp *interp) { InterpLibrary *ipPtr; LoadedLibrary *libraryPtr; while (1) { ipPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL); if (ipPtr == NULL) { break; } libraryPtr = ipPtr->libraryPtr; UnloadLibrary(interp, interp, libraryPtr, 0 ,"", 1); } } /* *---------------------------------------------------------------------- * * TclFinalizeLoad -- |
︙ | ︙ |
Changes to generic/tclMain.c.
︙ | ︙ | |||
272 273 274 275 276 277 278 | * interpreted. * *---------------------------------------------------------------------- */ TCL_NORETURN void Tcl_MainEx( | | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 | * interpreted. * *---------------------------------------------------------------------- */ TCL_NORETURN void Tcl_MainEx( Tcl_Size argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc, /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ Tcl_Interp *interp) { |
︙ | ︙ | |||
735 736 737 738 739 740 741 | * Could be almost arbitrary, depending on the command that's typed. * *---------------------------------------------------------------------- */ static void StdinProc( | | | 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 | * Could be almost arbitrary, depending on the command that's typed. * *---------------------------------------------------------------------- */ static void StdinProc( void *clientData, /* The state of interactive cmd line */ TCL_UNUSED(int) /*mask*/) { int code; Tcl_Size length; InteractiveState *isPtr = (InteractiveState *)clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; |
︙ | ︙ |
Changes to generic/tclNamesp.c.
︙ | ︙ | |||
73 74 75 76 77 78 79 | static void DeleteImportedCmd(void *clientData); static int DoImport(Tcl_Interp *interp, Namespace *nsPtr, Tcl_HashEntry *hPtr, const char *cmdName, const char *pattern, Namespace *importNsPtr, int allowOverwrite); static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr); | | | | > | 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 | static void DeleteImportedCmd(void *clientData); static int DoImport(Tcl_Interp *interp, Namespace *nsPtr, Tcl_HashEntry *hPtr, const char *cmdName, const char *pattern, Namespace *importNsPtr, int allowOverwrite); static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr); static char * ErrorCodeRead(void *clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static char * ErrorInfoRead(void *clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static char * EstablishErrorCodeTraces(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static char * EstablishErrorInfoTraces(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); static int InvokeImportedNRCmd(void *clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static Tcl_ObjCmdProc NamespaceChildrenCmd; static Tcl_ObjCmdProc NamespaceCodeCmd; static Tcl_ObjCmdProc NamespaceCurrentCmd; static Tcl_ObjCmdProc NamespaceDeleteCmd; static Tcl_ObjCmdProc NamespaceEvalCmd; static Tcl_ObjCmdProc NRNamespaceEvalCmd; static Tcl_ObjCmdProc NamespaceExistsCmd; |
︙ | ︙ | |||
648 649 650 651 652 653 654 | Tcl_CreateNamespace( Tcl_Interp *interp, /* Interpreter in which a new namespace is * being created. Also used for error * reporting. */ const char *name, /* Name for the new namespace. May be a * qualified name with names of ancestor * namespaces separated by "::"s. */ | | | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 | Tcl_CreateNamespace( Tcl_Interp *interp, /* Interpreter in which a new namespace is * being created. Also used for error * reporting. */ const char *name, /* Name for the new namespace. May be a * qualified name with names of ancestor * namespaces separated by "::"s. */ void *clientData, /* One-word value to store with namespace. */ Tcl_NamespaceDeleteProc *deleteProc) /* Function called to delete client data when * the namespace is deleted. NULL if no * function should be called. */ { Interp *iPtr = (Interp *) interp; Namespace *nsPtr, *ancestorPtr; |
︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 | * Deletes all commands, variables and namespaces in this namespace. * *---------------------------------------------------------------------- */ void TclTeardownNamespace( | | | 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 | * Deletes all commands, variables and namespaces in this namespace. * *---------------------------------------------------------------------- */ void TclTeardownNamespace( Namespace *nsPtr) /* Points to the namespace to be dismantled * and unlinked from its parent. */ { Interp *iPtr = (Interp *) nsPtr->interp; Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Tcl_Size i; |
︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 | * None. * *---------------------------------------------------------------------- */ static void NamespaceFree( | | | 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 | * None. * *---------------------------------------------------------------------- */ static void NamespaceFree( Namespace *nsPtr) /* Points to the namespace to free. */ { /* * Most of the namespace's contents are freed when the namespace is * deleted by Tcl_DeleteNamespace. All that remains is to free its names * (for error messages), and the structure itself. */ |
︙ | ︙ | |||
1610 1611 1612 1613 1614 1615 1616 | * imported commands in autoloaded libraries and loads them in. That way, * they will be found when we try to create links below. * * Note that we don't just call Tcl_EvalObjv() directly because we do not * want absence of the command to be a failure case. */ | | | 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 | * imported commands in autoloaded libraries and loads them in. That way, * they will be found when we try to create links below. * * Note that we don't just call Tcl_EvalObjv() directly because we do not * want absence of the command to be a failure case. */ if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) { Tcl_Obj *objv[2]; int result; TclNewLiteralStringObj(objv[0], "auto_import"); objv[1] = Tcl_NewStringObj(pattern, -1); Tcl_IncrRefCount(objv[0]); |
︙ | ︙ | |||
2030 2031 2032 2033 2034 2035 2036 | * wrong, the result object is set to an error message. * *---------------------------------------------------------------------- */ static int InvokeImportedNRCmd( | | | | 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 | * wrong, the result object is set to an error message. * *---------------------------------------------------------------------- */ static int InvokeImportedNRCmd( void *clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { ImportedCmdData *dataPtr = (ImportedCmdData *)clientData; Command *realCmdPtr = dataPtr->realCmdPtr; TclSkipTailcall(interp); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } int TclInvokeImportedCmd( void *clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { return Tcl_NRCallObjProc(interp, InvokeImportedNRCmd, clientData, objc, objv); |
︙ | ︙ | |||
2078 2079 2080 2081 2082 2083 2084 | * Removes the imported command from the real command's import list. * *---------------------------------------------------------------------- */ static void DeleteImportedCmd( | | | 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 | * Removes the imported command from the real command's import list. * *---------------------------------------------------------------------- */ static void DeleteImportedCmd( void *clientData) /* Points to the imported command's * ImportedCmdData structure. */ { ImportedCmdData *dataPtr = (ImportedCmdData *)clientData; Command *realCmdPtr = dataPtr->realCmdPtr; Command *selfPtr = dataPtr->selfPtr; ImportRef *refPtr, *prevPtr; |
︙ | ︙ | |||
2517 2518 2519 2520 2521 2522 2523 | * (current namespace if contextNsPtr is * NULL), then in global namespace. */ Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or * if the name starts with "::". Otherwise, * points to namespace in which to resolve * name; if NULL, look up name in the current * namespace. */ | | | 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 | * (current namespace if contextNsPtr is * NULL), then in global namespace. */ Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or * if the name starts with "::". Otherwise, * points to namespace in which to resolve * name; if NULL, look up name in the current * namespace. */ int flags) /* Flags controlling namespace lookup: an OR'd * combination of TCL_GLOBAL_ONLY and * TCL_LEAVE_ERR_MSG flags. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; const char *dummy; /* |
︙ | ︙ | |||
3361 3362 3363 3364 3365 3366 3367 | * result. * *---------------------------------------------------------------------- */ static int NamespaceEvalCmd( | | | 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 | * result. * *---------------------------------------------------------------------- */ static int NamespaceEvalCmd( void *clientData, /* Arbitrary value passed to cmd. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc, objv); } |
︙ | ︙ | |||
3750 3751 3752 3753 3754 3755 3756 | TclNewObj(listPtr); for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc == DeleteImportedCmd) { Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj( | | | 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 | TclNewObj(listPtr); for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc == DeleteImportedCmd) { Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj( (char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1)); } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* |
︙ | ︙ | |||
3810 3811 3812 3813 3814 3815 3816 | * Returns a result in the Tcl interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceInscopeCmd( | | | 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 | * Returns a result in the Tcl interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceInscopeCmd( void *clientData, /* Arbitrary value passed to cmd. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc, objv); } |
︙ | ︙ | |||
4682 4683 4684 4685 4686 4687 4688 | goto badArgs; } } TclNewObj(resultPtr); switch (lookupType) { case 0: { /* -command */ | | | | 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 | goto badArgs; } } TclNewObj(resultPtr); switch (lookupType) { case 0: { /* -command */ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); if (cmd != NULL) { Tcl_GetCommandFullName(interp, cmd, resultPtr); } break; } case 1: { /* -variable */ Tcl_Var var = Tcl_FindNamespaceVar(interp, TclGetString(objv[objc-1]), NULL, /*flags*/ 0); if (var != NULL) { Tcl_GetVariableFullName(interp, var, resultPtr); } break; } } |
︙ | ︙ | |||
4724 4725 4726 4727 4728 4729 4730 | * the namespace, it's structure will be freed. * *---------------------------------------------------------------------- */ static void FreeNsNameInternalRep( | | | 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 | * the namespace, it's structure will be freed. * *---------------------------------------------------------------------- */ static void FreeNsNameInternalRep( Tcl_Obj *objPtr) /* nsName object with internal representation * to free. */ { ResolvedNsName *resNamePtr; NsNameGetInternalRep(objPtr, resNamePtr); assert(resNamePtr != NULL); |
︙ | ︙ | |||
4771 4772 4773 4774 4775 4776 4777 | * *---------------------------------------------------------------------- */ static void DupNsNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ | | | 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 | * *---------------------------------------------------------------------- */ static void DupNsNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { ResolvedNsName *resNamePtr; NsNameGetInternalRep(srcPtr, resNamePtr); assert(resNamePtr != NULL); NsNameSetInternalRep(copyPtr, resNamePtr); } |
︙ | ︙ | |||
4807 4808 4809 4810 4811 4812 4813 | */ static int SetNsNameFromAny( Tcl_Interp *interp, /* Points to the namespace in which to resolve * name. Also used for error reporting if not * NULL. */ | | | | 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 | */ static int SetNsNameFromAny( Tcl_Interp *interp, /* Points to the namespace in which to resolve * name. Also used for error reporting if not * NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { const char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; ResolvedNsName *resNamePtr; const char *name; if (interp == NULL) { return TCL_ERROR; } name = TclGetString(objPtr); TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { return TCL_ERROR; } /* * If we found a namespace, then create a new ResolvedNsName structure |
︙ | ︙ |
Changes to generic/tclNotify.c.
︙ | ︙ | |||
67 68 69 70 71 72 73 | * elapsed time for the next block. */ int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being called * during an event source traversal. */ EventSource *firstEventSourcePtr; /* Pointer to first event source in list of * event sources for this thread. */ Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */ | | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | * elapsed time for the next block. */ int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being called * during an event source traversal. */ EventSource *firstEventSourcePtr; /* Pointer to first event source in list of * event sources for this thread. */ Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */ void *clientData; /* Opaque handle for platform specific * notifier. */ int initialized; /* 1 if notifier has been initialized. */ struct ThreadSpecificData *nextPtr; /* Next notifier in global list of notifiers. * Access is controlled by the listLock global * mutex. */ } ThreadSpecificData; |
︙ | ︙ | |||
301 302 303 304 305 306 307 | Tcl_CreateEventSource( Tcl_EventSetupProc *setupProc, /* Function to invoke to figure out what to * wait for. */ Tcl_EventCheckProc *checkProc, /* Function to call after waiting to see what * happened. */ | | | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | Tcl_CreateEventSource( Tcl_EventSetupProc *setupProc, /* Function to invoke to figure out what to * wait for. */ Tcl_EventCheckProc *checkProc, /* Function to call after waiting to see what * happened. */ void *clientData) /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); EventSource *sourcePtr = (EventSource *)Tcl_Alloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; |
︙ | ︙ | |||
340 341 342 343 344 345 346 | Tcl_DeleteEventSource( Tcl_EventSetupProc *setupProc, /* Function to invoke to figure out what to * wait for. */ Tcl_EventCheckProc *checkProc, /* Function to call after waiting to see what * happened. */ | | | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 | Tcl_DeleteEventSource( Tcl_EventSetupProc *setupProc, /* Function to invoke to figure out what to * wait for. */ Tcl_EventCheckProc *checkProc, /* Function to call after waiting to see what * happened. */ void *clientData) /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); EventSource *sourcePtr, *prevPtr; for (sourcePtr = tsdPtr->firstEventSourcePtr, prevPtr = NULL; sourcePtr != NULL; |
︙ | ︙ | |||
552 553 554 555 556 557 558 | * *---------------------------------------------------------------------- */ void Tcl_DeleteEvents( Tcl_EventDeleteProc *proc, /* The function to call. */ | | | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 | * *---------------------------------------------------------------------- */ void Tcl_DeleteEvents( Tcl_EventDeleteProc *proc, /* The function to call. */ void *clientData) /* The type-specific data. */ { Tcl_Event *evPtr; /* Pointer to the event being examined */ Tcl_Event *prevPtr; /* Pointer to evPtr's predecessor, or NULL if * evPtr designates the first event in the * queue for the thread. */ Tcl_Event *hold; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
︙ | ︙ | |||
1249 1250 1251 1252 1253 1254 1255 | * See the platform-specific implementations. * *---------------------------------------------------------------------- */ void Tcl_AlertNotifier( | | | 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 | * See the platform-specific implementations. * *---------------------------------------------------------------------- */ void Tcl_AlertNotifier( void *clientData) /* Pointer to thread data. */ { if (tclNotifierHooks.alertNotifierProc) { tclNotifierHooks.alertNotifierProc(clientData); } else { TclpAlertNotifier(clientData); } } |
︙ | ︙ | |||
1306 1307 1308 1309 1310 1311 1312 | * See the platform-specific implementations. * *---------------------------------------------------------------------- */ void Tcl_SetTimer( | | | 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 | * See the platform-specific implementations. * *---------------------------------------------------------------------- */ void Tcl_SetTimer( const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { if (tclNotifierHooks.setTimerProc) { tclNotifierHooks.setTimerProc(timePtr); } else { TclpSetTimer(timePtr); } } |
︙ | ︙ | |||
1337 1338 1339 1340 1341 1342 1343 | * Queues file events that are detected by the notifier. * *---------------------------------------------------------------------- */ int Tcl_WaitForEvent( | | | 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 | * Queues file events that are detected by the notifier. * *---------------------------------------------------------------------- */ int Tcl_WaitForEvent( const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { if (tclNotifierHooks.waitForEventProc) { return tclNotifierHooks.waitForEventProc(timePtr); } else { return TclpWaitForEvent(timePtr); } } |
︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ | | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ void *clientData) /* Arbitrary data to pass to proc. */ { if (tclNotifierHooks.createFileHandlerProc) { tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); } else { TclpCreateFileHandler(fd, mask, proc, clientData); } } |
︙ | ︙ |
Changes to generic/tclOO.c.
︙ | ︙ | |||
100 101 102 103 104 105 106 | * Methods in the oo::object and oo::class classes. First, we define a helper * macro that makes building the method type declaration structure a lot * easier. No point in making life harder than it has to be! * * Note that the core methods don't need clone or free proc callbacks. */ | | | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | * Methods in the oo::object and oo::class classes. First, we define a helper * macro that makes building the method type declaration structure a lot * easier. No point in making life harder than it has to be! * * Note that the core methods don't need clone or free proc callbacks. */ #define DCM(name,visibility,proc) \ {name,visibility,\ {TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}} static const DeclaredClassMethod objMethods[] = { DCM("destroy", 1, TclOO_Object_Destroy), DCM("eval", 0, TclOO_Object_Eval), DCM("unknown", 0, TclOO_Object_Unknown), DCM("variable", 0, TclOO_Object_LinkVar), DCM("varname", 0, TclOO_Object_VarName), |
︙ | ︙ | |||
176 177 178 179 180 181 182 | */ #define Destructing(oPtr) ((oPtr)->flags & OBJECT_DESTRUCTING) #define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) #define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) | | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | */ #define Destructing(oPtr) ((oPtr)->flags & OBJECT_DESTRUCTING) #define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) #define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) #define RemoveItem(type, lst, i) \ do { \ Remove ## type ((lst).list, (lst).num, i); \ (lst).num--; \ } while (0) /* * ---------------------------------------------------------------------- * * RemoveClass, RemoveObject -- |
︙ | ︙ | |||
411 412 413 414 415 416 417 | cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectSelfCmd; Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, NULL); | | | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 | cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectSelfCmd; Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL); TclOOInitInfo(interp); /* * Now make the class of slots. */ if (TclOODefineSlots(fPtr) != TCL_OK) { |
︙ | ︙ | |||
572 573 574 575 576 577 578 | * * ---------------------------------------------------------------------- */ static void KillFoundation( TCL_UNUSED(void *), | | | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 | * * ---------------------------------------------------------------------- */ static void KillFoundation( TCL_UNUSED(void *), Tcl_Interp *interp) /* The interpreter containing the OO system * foundation. */ { Foundation *fPtr = GetFoundation(interp); TclDecrRefCount(fPtr->unknownMethodNameObj); TclDecrRefCount(fPtr->constructorName); TclDecrRefCount(fPtr->destructorName); TclDecrRefCount(fPtr->clonedName); |
︙ | ︙ | |||
747 748 749 750 751 752 753 | tracePtr->nextPtr = NULL; tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, | | | 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 | tracePtr->nextPtr = NULL; tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, MyClassDeleted); return oPtr; } /* * ---------------------------------------------------------------------- * * SquelchCachedName -- |
︙ | ︙ | |||
787 788 789 790 791 792 793 | * of those commands when the object itself is deleted. * * ---------------------------------------------------------------------- */ static void MyDeleted( | | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 | * of those commands when the object itself is deleted. * * ---------------------------------------------------------------------- */ static void MyDeleted( void *clientData) /* Reference to the object whose [my] has been * squelched. */ { Object *oPtr = (Object *)clientData; oPtr->myCommand = NULL; } |
︙ | ︙ | |||
818 819 820 821 822 823 824 | * object data structures. * * ---------------------------------------------------------------------- */ static void ObjectRenamedTrace( | | | 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 | * object data structures. * * ---------------------------------------------------------------------- */ static void ObjectRenamedTrace( void *clientData, /* The object being deleted. */ TCL_UNUSED(Tcl_Interp *), TCL_UNUSED(const char *) /*oldName*/, TCL_UNUSED(const char *) /*newName*/, int flags) /* Why was the object deleted? */ { Object *oPtr = (Object *)clientData; |
︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 | * (interpreter teardown is complex!) * * ---------------------------------------------------------------------- */ static void ObjectNamespaceDeleted( | | | 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 | * (interpreter teardown is complex!) * * ---------------------------------------------------------------------- */ static void ObjectNamespaceDeleted( void *clientData) /* Pointer to the class whose namespace is * being deleted. */ { Object *oPtr = (Object *)clientData; Foundation *fPtr = oPtr->fPtr; FOREACH_HASH_DECLS; Class *mixinPtr; Method *mPtr; |
︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 | Tcl_Interp *interp, /* Interpreter context. */ Tcl_Class cls, /* Class to create an instance of. */ const char *nameStr, /* Name of object to create, or NULL to ask * the code to pick its own unique name. */ const char *nsNameStr, /* Name of namespace to create inside object, * or NULL to ask the code to pick its own * unique name. */ | | | | 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 | Tcl_Interp *interp, /* Interpreter context. */ Tcl_Class cls, /* Class to create an instance of. */ const char *nameStr, /* Name of object to create, or NULL to ask * the code to pick its own unique name. */ const char *nsNameStr, /* Name of namespace to create inside object, * or NULL to ask the code to pick its own * unique name. */ Tcl_Size objc, /* Number of arguments. Negative value means * do not call constructor. */ Tcl_Obj *const *objv, /* Argument list. */ Tcl_Size skip) /* Number of arguments to _not_ pass to the * constructor. */ { Class *classPtr = (Class *) cls; Object *oPtr; void *clientData[4]; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); |
︙ | ︙ | |||
1782 1783 1784 1785 1786 1787 1788 | Tcl_Interp *interp, /* Interpreter context. */ Tcl_Class cls, /* Class to create an instance of. */ const char *nameStr, /* Name of object to create, or NULL to ask * the code to pick its own unique name. */ const char *nsNameStr, /* Name of namespace to create inside object, * or NULL to ask the code to pick its own * unique name. */ | | | | 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 | Tcl_Interp *interp, /* Interpreter context. */ Tcl_Class cls, /* Class to create an instance of. */ const char *nameStr, /* Name of object to create, or NULL to ask * the code to pick its own unique name. */ const char *nsNameStr, /* Name of namespace to create inside object, * or NULL to ask the code to pick its own * unique name. */ Tcl_Size objc, /* Number of arguments. Negative value means * do not call constructor. */ Tcl_Obj *const *objv, /* Argument list. */ Tcl_Size skip, /* Number of arguments to _not_ pass to the * constructor. */ Tcl_Object *objectPtr) /* Place to write the object reference upon * successful allocation. */ { Class *classPtr = (Class *) cls; CallContext *contextPtr; Tcl_InterpState state; |
︙ | ︙ | |||
2554 2555 2556 2557 2558 2559 2560 | int TclOOPublicObjectCmd( void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { | | | | 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 | int TclOOPublicObjectCmd( void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv); } static int PublicNRObjectCmd( void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, PUBLIC_METHOD, NULL); } int TclOOPrivateObjectCmd( void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv); } static int PrivateNRObjectCmd( void *clientData, Tcl_Interp *interp, int objc, |
︙ | ︙ | |||
2601 2602 2603 2604 2605 2606 2607 | * invoke from, or NULL to traverse the whole * chain including filters. */ int publicPrivate, /* Whether this is an invoke from a public * context (PUBLIC_METHOD), a private context * (PRIVATE_METHOD), or a *really* private * context (any other value; conventionally * 0). */ | | | 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 | * invoke from, or NULL to traverse the whole * chain including filters. */ int publicPrivate, /* Whether this is an invoke from a public * context (PUBLIC_METHOD), a private context * (PRIVATE_METHOD), or a *really* private * context (any other value; conventionally * 0). */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Array of argument objects. It is assumed * that the name of the method to invoke will * be at index 1. */ { switch (publicPrivate) { case PUBLIC_METHOD: return TclOOObjectCmdCore((Object *) object, interp, objc, objv, |
︙ | ︙ | |||
2672 2673 2674 2675 2676 2677 2678 | * ---------------------------------------------------------------------- */ int TclOOObjectCmdCore( Object *oPtr, /* The object being invoked. */ Tcl_Interp *interp, /* The interpreter containing the object. */ | | | 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 | * ---------------------------------------------------------------------- */ int TclOOObjectCmdCore( Object *oPtr, /* The object being invoked. */ Tcl_Interp *interp, /* The interpreter containing the object. */ Tcl_Size objc, /* How many arguments are being passed in. */ Tcl_Obj *const *objv, /* The array of arguments. */ int flags, /* Whether this is an invocation through the * public or the private command interface. */ Class *startCls) /* Where to start in the call chain, or NULL * if we are to start at the front with * filters and the object's methods (which is * the normal case). */ |
︙ | ︙ | |||
2806 2807 2808 2809 2810 2811 2812 | } /* * Invoke the call chain, locking the object structure against deletion * for the duration. */ | | | 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 | } /* * Invoke the call chain, locking the object structure against deletion * for the duration. */ TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL); return TclOOInvokeContext(contextPtr, interp, objc, objv); } static int FinalizeObjectCall( void *data[], TCL_UNUSED(Tcl_Interp *), |
︙ | ︙ |
Changes to generic/tclOOBasic.c.
︙ | ︙ | |||
889 890 891 892 893 894 895 | context = (Tcl_ObjectContext)framePtr->clientData; /* * Invoke the (advanced) method call context in the caller context. Note * that this is like [uplevel 1] and not [eval]. */ | | | 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 | context = (Tcl_ObjectContext)framePtr->clientData; /* * Invoke the (advanced) method call context in the caller context. Note * that this is like [uplevel 1] and not [eval]. */ TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL); iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } int TclOONextToObjCmd( TCL_UNUSED(void *), |
︙ | ︙ |
Changes to generic/tclOOCall.c.
︙ | ︙ | |||
21 22 23 24 25 26 27 | /* * Structure containing a CallContext and any other values needed only during * the construction of the CallContext. */ struct ChainBuilder { CallChain *callChainPtr; /* The call chain being built. */ | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | /* * Structure containing a CallContext and any other values needed only during * the construction of the CallContext. */ struct ChainBuilder { CallChain *callChainPtr; /* The call chain being built. */ size_t filterLength; /* Number of entries in the call chain that * are due to processing filters and not the * main call chain. */ Object *oPtr; /* The object that we are building the chain * for. */ }; /* |
︙ | ︙ | |||
304 305 306 307 308 309 310 | * in stack usage as possible. * * ---------------------------------------------------------------------- */ int TclOOInvokeContext( | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | * in stack usage as possible. * * ---------------------------------------------------------------------- */ int TclOOInvokeContext( void *clientData, /* The method call context. */ Tcl_Interp *interp, /* Interpreter for error reporting, and many * other sorts of context handling (e.g., * commands, variables) depending on method * implementation. */ int objc, /* The number of arguments. */ Tcl_Obj *const objv[]) /* The arguments as actually seen. */ { |
︙ | ︙ | |||
353 354 355 356 357 358 359 | } /* * Save whether we were in a filter and set up whether we are now. */ if (contextPtr->oPtr->flags & FILTER_HANDLING) { | | | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 | } /* * Save whether we were in a filter and set up whether we are now. */ if (contextPtr->oPtr->flags & FILTER_HANDLING) { TclNRAddCallback(interp, SetFilterFlags, contextPtr, NULL,NULL,NULL); } else { TclNRAddCallback(interp, ResetFilterFlags,contextPtr,NULL,NULL,NULL); } if (isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) { contextPtr->oPtr->flags |= FILTER_HANDLING; } else { contextPtr->oPtr->flags &= ~FILTER_HANDLING; } |
︙ | ︙ | |||
673 674 675 676 677 678 679 | * * ---------------------------------------------------------------------- */ static void AddClassMethodNames( Class *clsPtr, /* Class to get method names from. */ | | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 | * * ---------------------------------------------------------------------- */ static void AddClassMethodNames( Class *clsPtr, /* Class to get method names from. */ int flags, /* Whether we are interested in just the * public method names. */ Tcl_HashTable *const namesPtr, /* Reference to the hash table to put the * information in. The hash table maps the * Tcl_Obj * method name to an integral value * describing whether the method is wanted. * This ensures that public/private override |
︙ | ︙ | |||
2034 2035 2036 2037 2038 2039 2040 | * reallocating the space for the chain if necessary. * * ---------------------------------------------------------------------- */ static inline void AddDefinitionNamespaceToChain( | | | < | 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 | * reallocating the space for the chain if necessary. * * ---------------------------------------------------------------------- */ static inline void AddDefinitionNamespaceToChain( Class *const definerCls, /* What class defines this entry. */ Tcl_Obj *const namespaceName, /* The name for this entry (or NULL, a * no-op). */ DefineChain *const definePtr, /* The define chain to add the method * implementation to. */ int flags) /* Used to check if we're mixin-consistent * only. Mixin-consistent means that either * we're looking to add things from a mixin |
︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
︙ | ︙ | |||
36 37 38 39 40 41 42 | struct DeclaredSlot { const char *name; const Tcl_MethodType getterType; const Tcl_MethodType setterType; const Tcl_MethodType resolverType; }; | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | struct DeclaredSlot { const char *name; const Tcl_MethodType getterType; const Tcl_MethodType setterType; const Tcl_MethodType resolverType; }; #define SLOT(name,getter,setter,resolver) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ setter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \ resolver, NULL, NULL}} |
︙ | ︙ | |||
2650 2651 2652 2653 2654 2655 2656 | if (superclasses[i] == NULL) { goto failedAfterAlloc; } for (j = 0; j < i; j++) { if (superclasses[j] == superclasses[i]) { TclSetResult(interp, "class should only be a direct superclass once"); | | | 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 | if (superclasses[i] == NULL) { goto failedAfterAlloc; } for (j = 0; j < i; j++) { if (superclasses[j] == superclasses[i]) { TclSetResult(interp, "class should only be a direct superclass once"); Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",(char *)NULL); goto failedAfterAlloc; } } if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { TclSetResult(interp, "attempt to form circular dependency graph"); Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", (char *)NULL); |
︙ | ︙ |
Changes to generic/tclOOInfo.c.
︙ | ︙ | |||
615 616 617 618 619 620 621 | Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(names[i], -1)); } if (numNames > 0) { Tcl_Free((void *)names); } } else if (oPtr->methodsPtr) { | > > > > > > | > > > > > > | | > | 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 | Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(names[i], -1)); } if (numNames > 0) { Tcl_Free((void *)names); } } else if (oPtr->methodsPtr) { if (scope == -1) { /* * Handle legacy-mode matching. [Bug 36e5517a6850] */ int scopeFilter = flag | TRUE_PRIVATE_METHOD; FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { if (mPtr->typePtr && (mPtr->flags & scopeFilter) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } } else { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } |
︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 | } if (numNames > 0) { Tcl_Free((void *)names); } } else { FOREACH_HASH_DECLS; | > > > > > > | > > > > > > | | > | 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 | } if (numNames > 0) { Tcl_Free((void *)names); } } else { FOREACH_HASH_DECLS; if (scope == -1) { /* * Handle legacy-mode matching. [Bug 36e5517a6850] */ int scopeFilter = flag | TRUE_PRIVATE_METHOD; FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { if (mPtr->typePtr && (mPtr->flags & scopeFilter) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } } else { FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } |
︙ | ︙ |
Changes to generic/tclOOInt.h.
︙ | ︙ | |||
42 43 44 45 46 47 48 | */ typedef struct Method { const Tcl_MethodType *typePtr; /* The type of method. If NULL, this is a * special flag record which is just used for * the setting of the flags field. */ | | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | */ typedef struct Method { const Tcl_MethodType *typePtr; /* The type of method. If NULL, this is a * special flag record which is just used for * the setting of the flags field. */ Tcl_Size refCount; void *clientData; /* Type-specific data. */ Tcl_Obj *namePtr; /* Name of the method. */ struct Object *declaringObjectPtr; /* The object that declares this method, or * NULL if it was declared by a class. */ struct Class *declaringClassPtr; /* The class that declares this method, or * NULL if it was declared directly on an |
︙ | ︙ | |||
93 94 95 96 97 98 99 100 101 102 103 104 105 106 | * before the method executes. */ TclOO_PostCallProc *postCallProc; /* Callback to allow for additional cleanup * after the method executes. */ GetFrameInfoValueProc *gfivProc; /* Callback to allow for fine tuning of how * the method reports itself. */ } ProcedureMethod; #define TCLOO_PROCEDURE_METHOD_VERSION 0 /* * Flags for use in a ProcedureMethod. * | > > > > > > > > > > | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | * before the method executes. */ TclOO_PostCallProc *postCallProc; /* Callback to allow for additional cleanup * after the method executes. */ GetFrameInfoValueProc *gfivProc; /* Callback to allow for fine tuning of how * the method reports itself. */ Command cmd; /* Space used to connect to [info frame] */ ExtraFrameInfo efi; /* Space used to store data for [info frame] */ Tcl_Interp *interp; /* Interpreter in which to compute the name of * the method. */ Tcl_Method method; /* Method to compute the name of. */ int callSiteFlags; /* Flags from the call chain. Only interested * in whether this is a constructor or * destructor, which we can't know until then * for messy reasons. Other flags are variable * but not used. */ } ProcedureMethod; #define TCLOO_PROCEDURE_METHOD_VERSION 0 /* * Flags for use in a ProcedureMethod. * |
︙ | ︙ | |||
205 206 207 208 209 210 211 | * for everything else. It points to the class * structure. */ Tcl_Size refCount; /* Number of strong references to this object. * Note that there may be many more weak * references; this mechanism exists to * avoid Tcl_Preserve. */ int flags; | | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 | * for everything else. It points to the class * structure. */ Tcl_Size refCount; /* Number of strong references to this object. * Note that there may be many more weak * references; this mechanism exists to * avoid Tcl_Preserve. */ int flags; Tcl_Size creationEpoch; /* Unique value to make comparisons of objects * easier. */ Tcl_Size epoch; /* Per-object epoch, incremented when the way * an object should resolve call chains is * changed. */ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to * the void *values that are the values * of each piece of attached metadata. This * field starts out as NULL and is only * allocated if metadata is attached. */ |
︙ | ︙ | |||
515 516 517 518 519 520 521 | MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp, Object *useThisObj); MODULE_SCOPE int TclMethodIsType(Tcl_Method method, | | | | | | | | | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 | MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp, Object *useThisObj); MODULE_SCOPE int TclMethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, void **clientDataPtr); MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, Tcl_Size objc, Tcl_Obj *const *objv, Tcl_Size skip, Tcl_Object *objectPtr); MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, Class *classPtr, |
︙ | ︙ | |||
607 608 609 610 611 612 613 | /* * A convenience macro for iterating through the lists used in the internal * memory management of objects. * REQUIRES DECLARATION: Tcl_Size i; */ | | | | | | | | | < | | | < | | | | | < | | | | 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 | /* * A convenience macro for iterating through the lists used in the internal * memory management of objects. * REQUIRES DECLARATION: Tcl_Size i; */ #define FOREACH(var,ary) \ for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \ continue; \ } else if ((var) = (ary).list[i], 1) /* * A variation where the array is an array of structs. There's no issue with * possible NULLs; every element of the array will be iterated over and the * variable set to a pointer to each of those elements in turn. * REQUIRES DECLARATION: Tcl_Size i; See [96551aca55] for more FOREACH_STRUCT details. */ #define FOREACH_STRUCT(var,ary) \ if (i=0, (ary).num>0) for(; var=&((ary).list[i]), i<(ary).num; i++) /* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS * sets up the declarations needed for the main macro, FOREACH_HASH, which * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that * only iterates over values. * REQUIRES DECLARATION: FOREACH_HASH_DECLS; */ #define FOREACH_HASH_DECLS \ Tcl_HashEntry *hPtr;Tcl_HashSearch search #define FOREACH_HASH(key,val,tablePtr) \ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \ (*(void **)&(key)=Tcl_GetHashKey((tablePtr),hPtr),\ *(void **)&(val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search)) #define FOREACH_HASH_VALUE(val,tablePtr) \ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \ (*(void **)&(val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search)) /* * Convenience macro for duplicating a list. Needs no external declaration, * but all arguments are used multiple times and so must have no side effects. */ #undef DUPLICATE /* prevent possible conflict with definition in WINAPI nb30.h */ #define DUPLICATE(target,source,type) \ do { \ size_t len = sizeof(type) * ((target).num=(source).num);\ if (len != 0) { \ memcpy(((target).list=(type*)Tcl_Alloc(len)), (source).list, len); \ } else { \ (target).list = NULL; \ } \ } while(0) #endif /* TCL_OO_INTERNAL_H */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclOOMethod.c.
︙ | ︙ | |||
12 13 14 15 16 17 18 | #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" #include "tclCompile.h" | < < < < < < < < < < < | < < < | < < | 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 | #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" #include "tclCompile.h" /* * Structure used to contain all the information needed about a call frame * used in a procedure-like method. */ typedef struct { CallFrame *framePtr; /* Reference to the call frame itself (it's * actually allocated on the Tcl stack). */ ProcErrorProc *errProc; /* The error handler for the body. */ Tcl_Obj *nameObj; /* The "name" of the command. Only used for a * few moments, so not reference. */ } PMFrameData; /* * Structure used to pass information about variable resolution to the * on-the-ground resolvers used when working with resolved compiled variables. */ |
︙ | ︙ | |||
79 80 81 82 83 84 85 86 87 88 89 90 91 92 | static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); static void DeleteProcedureMethod(void *clientData); static int CloneProcedureMethod(Tcl_Interp *interp, void *clientData, void **newClientData); static ProcErrorProc MethodErrorHandler; static ProcErrorProc ConstructorErrorHandler; static ProcErrorProc DestructorErrorHandler; static Tcl_Obj * RenderDeclarerName(void *clientData); static int InvokeForwardMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static void DeleteForwardMethod(void *clientData); static int CloneForwardMethod(Tcl_Interp *interp, void *clientData, void **newClientData); | > | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); static void DeleteProcedureMethod(void *clientData); static int CloneProcedureMethod(Tcl_Interp *interp, void *clientData, void **newClientData); static ProcErrorProc MethodErrorHandler; static ProcErrorProc ConstructorErrorHandler; static ProcErrorProc DestructorErrorHandler; static Tcl_Obj * RenderMethodName(void *clientData); static Tcl_Obj * RenderDeclarerName(void *clientData); static int InvokeForwardMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static void DeleteForwardMethod(void *clientData); static int CloneForwardMethod(Tcl_Interp *interp, void *clientData, void **newClientData); |
︙ | ︙ | |||
110 111 112 113 114 115 116 117 118 119 120 121 122 123 | * Helper macros (derived from things private to tclVar.c) */ #define TclVarTable(contextNs) \ ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable)) #define TclVarHashGetValue(hPtr) \ ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry))) /* * ---------------------------------------------------------------------- * * Tcl_NewInstanceMethod -- * * Attach a method to an object instance. | > > > > > > > > > > > > > > | 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 | * Helper macros (derived from things private to tclVar.c) */ #define TclVarTable(contextNs) \ ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable)) #define TclVarHashGetValue(hPtr) \ ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry))) static inline ProcedureMethod * AllocProcedureMethodRecord( int flags) { ProcedureMethod *pmPtr = (ProcedureMethod *) Tcl_Alloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; pmPtr->refCount = 1; pmPtr->cmd.clientData = &pmPtr->efi; return pmPtr; } /* * ---------------------------------------------------------------------- * * Tcl_NewInstanceMethod -- * * Attach a method to an object instance. |
︙ | ︙ | |||
264 265 266 267 268 269 270 | if (nameObj == NULL) { mPtr = (Method *)Tcl_Alloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } | | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 | if (nameObj == NULL) { mPtr = (Method *)Tcl_Alloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, nameObj,&isNew); if (isNew) { mPtr = (Method *)Tcl_Alloc(sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = nameObj; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { |
︙ | ︙ | |||
424 425 426 427 428 429 430 | Tcl_Size argsLen; ProcedureMethod *pmPtr; Tcl_Method method; if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } | < < < < < | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 | Tcl_Size argsLen; ProcedureMethod *pmPtr; Tcl_Method method; if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } pmPtr = AllocProcedureMethodRecord(flags); method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (method == NULL) { Tcl_Free(pmPtr); } else if (pmPtrPtr != NULL) { *pmPtrPtr = pmPtr; } |
︙ | ︙ | |||
485 486 487 488 489 490 491 | procName = "<destructor>"; } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } else { procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj)); } | < < < < < | | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 | procName = "<destructor>"; } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } else { procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj)); } pmPtr = AllocProcedureMethodRecord(flags); method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (argsLen == TCL_INDEX_NONE) { Tcl_DecrRefCount(argsObj); } if (method == NULL) { |
︙ | ︙ | |||
532 533 534 535 536 537 538 | * NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, * which _must not_ be NULL. */ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ | | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 | * NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, * which _must not_ be NULL. */ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ void *clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the * pointer in clientData. */ { Interp *iPtr = (Interp *) interp; Proc *procPtr; |
︙ | ︙ | |||
645 646 647 648 649 650 651 | * _must not_ be NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, * which _must not_ be NULL. */ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ | | | 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 | * _must not_ be NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, * which _must not_ be NULL. */ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ void *clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the * pointer in clientData. */ { Interp *iPtr = (Interp *) interp; Proc *procPtr; |
︙ | ︙ | |||
762 763 764 765 766 767 768 769 770 771 772 773 774 775 | */ if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) || Tcl_InterpDeleted(interp)) { return TclNRObjectContextInvokeNext(interp, context, objc, objv, Tcl_ObjectContextSkippedArgs(context)); } /* * Allocate the special frame data. */ fdPtr = (PMFrameData *)TclStackAlloc(interp, sizeof(PMFrameData)); | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | */ if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) || Tcl_InterpDeleted(interp)) { return TclNRObjectContextInvokeNext(interp, context, objc, objv, Tcl_ObjectContextSkippedArgs(context)); } /* * Finishes filling out the extra frame info so that [info frame] works if * that is not already set up. */ if (pmPtr->efi.length == 0) { Tcl_Method method = Tcl_ObjectContextMethod(context); pmPtr->efi.length = 2; pmPtr->efi.fields[0].name = "method"; pmPtr->efi.fields[0].proc = RenderMethodName; pmPtr->efi.fields[0].clientData = pmPtr; pmPtr->callSiteFlags = ((CallContext *) context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR); pmPtr->interp = interp; pmPtr->method = method; if (pmPtr->gfivProc != NULL) { pmPtr->efi.fields[1].name = ""; pmPtr->efi.fields[1].proc = pmPtr->gfivProc; pmPtr->efi.fields[1].clientData = pmPtr; } else { if (Tcl_MethodDeclarerObject(method) != NULL) { pmPtr->efi.fields[1].name = "object"; } else { pmPtr->efi.fields[1].name = "class"; } pmPtr->efi.fields[1].proc = RenderDeclarerName; pmPtr->efi.fields[1].clientData = pmPtr; } } /* * Allocate the special frame data. */ fdPtr = (PMFrameData *)TclStackAlloc(interp, sizeof(PMFrameData)); |
︙ | ︙ | |||
792 793 794 795 796 797 798 | if (pmPtr->preCallProc != NULL) { int isFinished; result = pmPtr->preCallProc(pmPtr->clientData, interp, context, (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { | < < < < < < < | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 | if (pmPtr->preCallProc != NULL) { int isFinished; result = pmPtr->preCallProc(pmPtr->clientData, interp, context, (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { Tcl_PopCallFrame(interp); TclStackFree(interp, fdPtr->framePtr); if (pmPtr->refCount-- <= 1) { DeleteProcedureMethodRecord(pmPtr); } TclStackFree(interp, fdPtr); return result; |
︙ | ︙ | |||
839 840 841 842 843 844 845 | if (pmPtr->postCallProc) { result = pmPtr->postCallProc(pmPtr->clientData, interp, context, Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)), result); } | < < < < < < < | 852 853 854 855 856 857 858 859 860 861 862 863 864 865 | if (pmPtr->postCallProc) { result = pmPtr->postCallProc(pmPtr->clientData, interp, context, Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)), result); } /* * Scrap the special frame data now that we're done with it. Note that we * are inlining DeleteProcedureMethod() here; this location is highly * sensitive when it comes to performance! */ if (pmPtr->refCount-- <= 1) { |
︙ | ︙ | |||
872 873 874 875 876 877 878 | int objc, /* Number of arguments. */ Tcl_Obj *const *objv, /* Array of arguments. */ PMFrameData *fdPtr) /* Place to store information about the call * frame. */ { Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; int result; | < < < < < | < < < < < < < < | < | < < < < < < < > | > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 909 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 | int objc, /* Number of arguments. */ Tcl_Obj *const *objv, /* Array of arguments. */ PMFrameData *fdPtr) /* Place to store information about the call * frame. */ { Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; int result; CallFrame **framePtrPtr = &fdPtr->framePtr; ByteCode *codePtr; /* * Compute basic information on the basis of the type of method it is. */ if (contextPtr->callPtr->flags & CONSTRUCTOR) { fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName; fdPtr->errProc = ConstructorErrorHandler; } else if (contextPtr->callPtr->flags & DESTRUCTOR) { fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName; fdPtr->errProc = DestructorErrorHandler; } else { fdPtr->nameObj = Tcl_MethodName( Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr)); fdPtr->errProc = MethodErrorHandler; } if (pmPtr->errProc != NULL) { fdPtr->errProc = pmPtr->errProc; } /* * Magic to enable things like [incr Tcl], which wants methods to run in * their class's namespace. */ if (pmPtr->flags & USE_DECLARER_NS) { Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; if (mPtr->declaringClassPtr != NULL) { nsPtr = (Namespace *) mPtr->declaringClassPtr->thisPtr->namespacePtr; } else { nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr; } } /* * Compile the body. * * [Bug 2037727] Always call TclProcCompileProc so that we check not only * 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... */ pmPtr->procPtr->cmdPtr = &pmPtr->cmd; ByteCodeGetInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr); if (codePtr) { codePtr->nsPtr = nsPtr; } result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, nsPtr, "body of method", TclGetString(fdPtr->nameObj)); if (result != TCL_OK) { return result; } /* * Make the stack frame and fill it out with information about this call. * This operation doesn't ever actually fail. */ (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD); fdPtr->framePtr->clientData = contextPtr; fdPtr->framePtr->objc = objc; fdPtr->framePtr->objv = objv; fdPtr->framePtr->procPtr = pmPtr->procPtr; return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOOSetupVariableResolver, etc. -- * |
︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 | *rPtrPtr = &infoPtr->info; return TCL_OK; } /* * ---------------------------------------------------------------------- * * RenderDeclarerName -- * * Returns the name of the entity (object or class) which declared a * method. Used for producing information for [info frame] in such a way * that the expensive part of this (generating the object or class name * itself) isn't done until it is needed. * * ---------------------------------------------------------------------- */ static Tcl_Obj * RenderDeclarerName( void *clientData) { | > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | 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 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 | *rPtrPtr = &infoPtr->info; return TCL_OK; } /* * ---------------------------------------------------------------------- * * RenderMethodName -- * * Returns the name of the declared method. Used for producing information * for [info frame]. * * ---------------------------------------------------------------------- */ static Tcl_Obj * RenderMethodName( void *clientData) { ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; if (pmPtr->callSiteFlags & CONSTRUCTOR) { return TclOOGetFoundation(pmPtr->interp)->constructorName; } else if (pmPtr->callSiteFlags & DESTRUCTOR) { return TclOOGetFoundation(pmPtr->interp)->destructorName; } else { return Tcl_MethodName(pmPtr->method); } } /* * ---------------------------------------------------------------------- * * RenderDeclarerName -- * * Returns the name of the entity (object or class) which declared a * method. Used for producing information for [info frame] in such a way * that the expensive part of this (generating the object or class name * itself) isn't done until it is needed. * * ---------------------------------------------------------------------- */ static Tcl_Obj * RenderDeclarerName( void *clientData) { ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; Tcl_Object object = Tcl_MethodDeclarerObject(pmPtr->method); if (object == NULL) { object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pmPtr->method)); } return TclOOObjectName(pmPtr->interp, (Object *) object); } /* * ---------------------------------------------------------------------- * * MethodErrorHandler, ConstructorErrorHandler, DestructorErrorHandler -- * * How to fill in the stack trace correctly upon error in various forms * of procedure-like methods. LIMIT is how long the inserted strings in * the error traces should get before being converted to have ellipses, * and ELLIPSIFY is a macro to do the conversion (with the help of a * %.*s%s format field). Note that ELLIPSIFY is only safe for use in * suitable formatting contexts. * * ---------------------------------------------------------------------- */ /* TODO: Check whether Tcl_AppendLimitedToObj() can work here. */ #define LIMIT 60 #define ELLIPSIFY(str,len) \ ((len) > LIMIT ? LIMIT : (int)(len)), (str), ((len) > LIMIT ? "..." : "") static void MethodErrorHandler( Tcl_Interp *interp, TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/) /* We pull the method name out of context instead of from argument */ |
︙ | ︙ | |||
1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 | * Create the actual copy of the method record, manufacturing a new proc * record. */ pm2Ptr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; Tcl_IncrRefCount(argsObj); Tcl_IncrRefCount(bodyObj); if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, &pm2Ptr->procPtr) != TCL_OK) { Tcl_DecrRefCount(argsObj); Tcl_DecrRefCount(bodyObj); Tcl_Free(pm2Ptr); | > > | 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 | * Create the actual copy of the method record, manufacturing a new proc * record. */ pm2Ptr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; pm2Ptr->cmd.clientData = &pm2Ptr->efi; pm2Ptr->efi.length = 0; /* Trigger a reinit of this. */ Tcl_IncrRefCount(argsObj); Tcl_IncrRefCount(bodyObj); if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, &pm2Ptr->procPtr) != TCL_OK) { Tcl_DecrRefCount(argsObj); Tcl_DecrRefCount(bodyObj); Tcl_Free(pm2Ptr); |
︙ | ︙ | |||
1538 1539 1540 1541 1542 1543 1544 | * command rearranging and then invokes some other Tcl command. * * ---------------------------------------------------------------------- */ static int InvokeForwardMethod( | | | 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 | * command rearranging and then invokes some other Tcl command. * * ---------------------------------------------------------------------- */ static int InvokeForwardMethod( void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = (ForwardMethod *)clientData; |
︙ | ︙ |
Changes to generic/tclObj.c.
︙ | ︙ | |||
74 75 76 77 78 79 80 | * * Notice that different structures with the same name appear in other files. * The structure defined below is used in this file only. */ typedef struct { Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj | | | | | | | | | | | | | | | 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 | * * Notice that different structures with the same name appear in other files. * The structure defined below is used in this file only. */ typedef struct { Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj * generated by a call to the function * TclSubstTokens() from a literal text * where bs+nl sequences occurred in it, if * any. I.e. this table keeps track of * invisible and stripped continuation lines. * Its keys are Tcl_Obj pointers, the values * are ContLineLoc pointers. See the file * tclCompile.h for the definition of this * structure, and for references to all * related places in the core. */ #if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashTable *objThreadMap;/* Thread local table that is used to check * that a Tcl_Obj was not allocated by some * other thread. */ #endif /* TCL_MEM_DEBUG && TCL_THREADS */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; static void TclThreadFinalizeContLines(void *clientData); static ThreadSpecificData *TclGetContLineTable(void); /* * Nested Tcl_Obj deletion management support * * All context references used in the object freeing code are pointers to this * structure; every thread will have its own structure instance. The purpose |
︙ | ︙ | |||
141 142 143 144 145 146 147 | * These are separated out so that some semantic content is attached * to them. */ #define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) | | | | | | | | | | | | | | < | | | 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 | * These are separated out so that some semantic content is attached * to them. */ #define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) #define PushObjToDelete(contextPtr,objPtr) \ /* The string rep is already invalidated so we can use the bytes value \ * for our pointer chain: push onto the head of the stack. */ \ (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ (contextPtr)->deletionStack = (objPtr) #define PopObjToDelete(contextPtr,objPtrVar) \ (objPtrVar) = (contextPtr)->deletionStack; \ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes /* * Macro to set up the local reference to the deletion context. */ #if !TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData #elif defined(HAVE_FAST_TSD) static __thread PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = \ (PendingObjData *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif /* * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep */ #define PACK_BIGNUM(bignum, objPtr) \ if ((bignum).used > 0x7FFF) { \ mp_int *temp = (mp_int *)Tcl_Alloc(sizeof(mp_int)); \ *temp = bignum; \ (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \ (objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ | ((bignum).alloc << 15) | ((bignum).used)); \ } /* * Prototypes for functions defined later in this file: */ static int ParseBoolean(Tcl_Obj *objPtr); |
︙ | ︙ | |||
512 513 514 515 516 517 518 | */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->lineCLPtr) { tsdPtr->lineCLPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); | | | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 | */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->lineCLPtr) { tsdPtr->lineCLPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); } return tsdPtr; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
574 575 576 577 578 579 580 | */ Tcl_Free(Tcl_GetHashValue(hPtr)); } clLocPtr->num = num; memcpy(&clLocPtr->loc, loc, num*sizeof(Tcl_Size)); | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 | */ Tcl_Free(Tcl_GetHashValue(hPtr)); } clLocPtr->num = num; memcpy(&clLocPtr->loc, loc, num*sizeof(Tcl_Size)); clLocPtr->loc[num] = CLL_END; /* Sentinel */ Tcl_SetHashValue(hPtr, clLocPtr); return clLocPtr; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
634 635 636 637 638 639 640 | /* * First compute the range of the word within the script. (Is there a * better way which doesn't shimmer?) */ (void)TclGetStringFromObj(objPtr, &length); | | | 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 | /* * First compute the range of the word within the script. (Is there a * better way which doesn't shimmer?) */ (void)TclGetStringFromObj(objPtr, &length); end = start + length; /* First char after the word */ /* * Then compute the table slice covering the range of the word. */ while (*wordCLLast >= 0 && *wordCLLast < end) { wordCLLast++; |
︙ | ︙ | |||
699 700 701 702 703 704 705 | void TclContinuationsCopy( Tcl_Obj *objPtr, Tcl_Obj *originObjPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); | > | | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 | void TclContinuationsCopy( Tcl_Obj *objPtr, Tcl_Obj *originObjPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr); if (hPtr) { ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr); TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); } } |
︙ | ︙ | |||
732 733 734 735 736 737 738 | */ ContLineLoc * TclContinuationsGet( Tcl_Obj *objPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); | > | | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 | */ ContLineLoc * TclContinuationsGet( Tcl_Obj *objPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (!hPtr) { return NULL; } return (ContLineLoc *)Tcl_GetHashValue(hPtr); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void TclDbInitNewObj( Tcl_Obj *objPtr, | | | | 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void TclDbInitNewObj( Tcl_Obj *objPtr, const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { objPtr->refCount = 0; objPtr->typePtr = NULL; TclInitEmptyStringRep(objPtr); #if TCL_THREADS |
︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewObj( | | | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewObj( const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. */ |
︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void TclFreeObj( | | | 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void TclFreeObj( Tcl_Obj *objPtr) /* The object to be freed. */ { const Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... */ |
︙ | ︙ | |||
1374 1375 1376 1377 1378 1379 1380 | * already killed the thread-global data structures. Performing * TCL_TSD_INIT will leave us with an uninitialized memory block upon * which we crash (if we where to access the uninitialized hashtable). */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); | | | | | 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 | * already killed the thread-global data structures. Performing * TCL_TSD_INIT will leave us with an uninitialized memory block upon * which we crash (if we where to access the uninitialized hashtable). */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_HashEntry *hPtr; if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { Tcl_Free(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } } } #else /* TCL_MEM_DEBUG */ void TclFreeObj( Tcl_Obj *objPtr) /* The object to be freed. */ { /* * Invalidate the string rep first so we can use the bytes value for our * pointer chain, and signal an obj deletion (as opposed to shimmering) * with 'length == -1'. */ |
︙ | ︙ | |||
1465 1466 1467 1468 1469 1470 1471 | * already killed the thread-global data structures. Performing * TCL_TSD_INIT will leave us with an uninitialized memory block upon * which we crash (if we where to access the uninitialized hashtable). */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); | | | | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 | * already killed the thread-global data structures. Performing * TCL_TSD_INIT will leave us with an uninitialized memory block upon * which we crash (if we where to access the uninitialized hashtable). */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_HashEntry *hPtr; if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { Tcl_Free(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } } } |
︙ | ︙ | |||
1532 1533 1534 1535 1536 1537 1538 | * objects it points to will not actually be copied but will be shared * with the duplicate list. That is, the ref counts of the element * objects will be incremented. * *---------------------------------------------------------------------- */ | | | 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 | * objects it points to will not actually be copied but will be shared * with the duplicate list. That is, the ref counts of the element * objects will be incremented. * *---------------------------------------------------------------------- */ #define SetDuplicateObj(dupPtr, objPtr) \ { \ const Tcl_ObjType *typePtr = (objPtr)->typePtr; \ const char *bytes = (objPtr)->bytes; \ if (bytes) { \ TclInitStringRep((dupPtr), bytes, (objPtr)->length); \ } else { \ (dupPtr)->bytes = NULL; \ |
︙ | ︙ | |||
1599 1600 1601 1602 1603 1604 1605 | * *---------------------------------------------------------------------- */ #undef Tcl_GetString char * Tcl_GetString( | | | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 | * *---------------------------------------------------------------------- */ #undef Tcl_GetString char * Tcl_GetString( Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be returned. */ { if (objPtr->bytes == NULL) { /* * Note we do not check for objPtr->typePtr == NULL. An invariant * of a properly maintained Tcl_Obj is that at least one of * objPtr->bytes and objPtr->typePtr must not be NULL. If broken |
︙ | ︙ | |||
1657 1658 1659 1660 1661 1662 1663 | *---------------------------------------------------------------------- */ #if !defined(TCL_NO_DEPRECATED) #undef TclGetStringFromObj char * TclGetStringFromObj( | | | | 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 | *---------------------------------------------------------------------- */ #if !defined(TCL_NO_DEPRECATED) #undef TclGetStringFromObj char * TclGetStringFromObj( Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ void *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { if (objPtr->bytes == NULL) { /* * Note we do not check for objPtr->typePtr == NULL. An invariant * of a properly maintained Tcl_Obj is that at least one of |
︙ | ︙ | |||
1702 1703 1704 1705 1706 1707 1708 | return objPtr->bytes; } #endif /* !defined(TCL_NO_DEPRECATED) */ #undef Tcl_GetStringFromObj char * Tcl_GetStringFromObj( | | | 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 | return objPtr->bytes; } #endif /* !defined(TCL_NO_DEPRECATED) */ #undef Tcl_GetStringFromObj char * Tcl_GetStringFromObj( Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ Tcl_Size *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { if (objPtr->bytes == NULL) { /* |
︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 | * As described above. * *---------------------------------------------------------------------- */ char * Tcl_InitStringRep( | | | 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 | * As described above. * *---------------------------------------------------------------------- */ char * Tcl_InitStringRep( Tcl_Obj *objPtr, /* Object whose string rep is to be set */ const char *bytes, size_t numBytes) { assert(objPtr->bytes == NULL || bytes == NULL); if (objPtr->bytes == NULL) { /* Start with no string rep */ |
︙ | ︙ | |||
1856 1857 1858 1859 1860 1861 1862 | * the string representation NULL to mark it invalid. * *---------------------------------------------------------------------- */ void Tcl_InvalidateStringRep( | | | | 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 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 | * the string representation NULL to mark it invalid. * *---------------------------------------------------------------------- */ void Tcl_InvalidateStringRep( Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be freed. */ { TclInvalidateStringRep(objPtr); } /* *---------------------------------------------------------------------- * * Tcl_HasStringRep -- * * This function reports whether object has a string representation. * * Results: * Boolean. *---------------------------------------------------------------------- */ int Tcl_HasStringRep( Tcl_Obj *objPtr) /* Object to test */ { return TclHasStringRep(objPtr); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1907 1908 1909 1910 1911 1912 1913 | *---------------------------------------------------------------------- */ void Tcl_StoreInternalRep( Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ const Tcl_ObjType *typePtr, /* New type for the object */ | | < | 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 | *---------------------------------------------------------------------- */ void Tcl_StoreInternalRep( Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ const Tcl_ObjType *typePtr, /* New type for the object */ const Tcl_ObjInternalRep *irPtr) /* New internalrep for the object */ { /* Clear out any existing internalrep ( "shimmer" ) */ TclFreeInternalRep(objPtr); /* When irPtr == NULL, just leave objPtr with no internalrep for typePtr */ if (irPtr) { /* Copy the new internalrep into place */ |
︙ | ︙ | |||
1969 1970 1971 1972 1973 1974 1975 | * Sets typePtr field to NULL. * *---------------------------------------------------------------------- */ void Tcl_FreeInternalRep( | | | 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 | * Sets typePtr field to NULL. * *---------------------------------------------------------------------- */ void Tcl_FreeInternalRep( Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ { TclFreeInternalRep(objPtr); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1996 1997 1998 1999 2000 2001 2002 | * *---------------------------------------------------------------------- */ #undef Tcl_GetBoolFromObj int Tcl_GetBoolFromObj( | | | | < | | < | < < | < | 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 | * *---------------------------------------------------------------------- */ #undef Tcl_GetBoolFromObj int Tcl_GetBoolFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get boolean. */ int flags, char *charPtr) /* Place to store resulting boolean. */ { int result; if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) { result = -1; goto boolEnd; } else if (objPtr == NULL) { if (interp) { TclNewObj(objPtr); TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) ? "boolean value or \"\"" : "boolean value", NULL, TCL_INDEX_NONE, NULL, 0); Tcl_DecrRefCount(objPtr); } return TCL_ERROR; } do { if (TclHasInternalRep(objPtr, &tclIntType) || TclHasInternalRep(objPtr, &tclBooleanType)) { result = (objPtr->internalRep.wideValue != 0); goto boolEnd; } if (TclHasInternalRep(objPtr, &tclDoubleType)) { /* * Caution: Don't be tempted to check directly for the "double" * Tcl_ObjType and then compare the internalrep to 0.0. This isn't |
︙ | ︙ | |||
2063 2064 2065 2066 2067 2068 2069 | } } *charPtr = result; } return TCL_OK; } } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == | | < | < < | | | | < | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 | } } *charPtr = result; } return TCL_OK; } } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) ? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } #undef Tcl_GetBooleanFromObj int Tcl_GetBooleanFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get boolean. */ int *intPtr) /* Place to store resulting boolean. */ { return Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof(int), (char *)(void *)intPtr); } /* *---------------------------------------------------------------------- * * TclSetBooleanFromAny -- * |
︙ | ︙ | |||
2105 2106 2107 2108 2109 2110 2111 | * *---------------------------------------------------------------------- */ int TclSetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ | | | 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 | * *---------------------------------------------------------------------- */ int TclSetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { /* * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine * whether a boolean conversion is possible without generating the string * rep. */ |
︙ | ︙ | |||
2151 2152 2153 2154 2155 2156 2157 | Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", (void *)NULL); } return TCL_ERROR; } static int ParseBoolean( | | | 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 | Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", (void *)NULL); } return TCL_ERROR; } static int ParseBoolean( Tcl_Obj *objPtr) /* The object to parse/convert. */ { int newBool; char lowerCase[6]; Tcl_Size i, length; const char *str = Tcl_GetStringFromObj(objPtr, &length); if ((length < 1) || (length > 5)) { |
︙ | ︙ | |||
2293 2294 2295 2296 2297 2298 2299 | */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewDoubleObj Tcl_Obj * Tcl_NewDoubleObj( | | | | 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 | */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewDoubleObj Tcl_Obj * Tcl_NewDoubleObj( double dblValue) /* Double used to initialize the object. */ { return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewDoubleObj( double dblValue) /* Double used to initialize the object. */ { Tcl_Obj *objPtr; TclNewDoubleObj(objPtr, dblValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ |
︙ | ︙ | |||
2341 2342 2343 2344 2345 2346 2347 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewDoubleObj( | | | | 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewDoubleObj( double dblValue, /* Double used to initialize the object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; objPtr->typePtr = &tclDoubleType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewDoubleObj( double dblValue, /* Double used to initialize the object. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { return Tcl_NewDoubleObj(dblValue); } #endif /* TCL_MEM_DEBUG */ |
︙ | ︙ | |||
2390 2391 2392 2393 2394 2395 2396 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetDoubleObj( | | | | 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetDoubleObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ double dblValue) /* Double used to set the object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj"); } TclSetDoubleObj(objPtr, dblValue); } |
︙ | ︙ | |||
2422 2423 2424 2425 2426 2427 2428 | * old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetDoubleFromObj( | | | | | | | 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 | * old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetDoubleFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get a double. */ double *dblPtr) /* Place to store resulting double. */ { do { if (TclHasInternalRep(objPtr, &tclDoubleType)) { if (isnan(objPtr->internalRep.doubleValue)) { if (interp != NULL) { TclSetResult(interp, "floating point value is Not a Number"); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", (void *)NULL); } return TCL_ERROR; } *dblPtr = (double) objPtr->internalRep.doubleValue; return TCL_OK; } if (TclHasInternalRep(objPtr, &tclIntType)) { |
︙ | ︙ | |||
2477 2478 2479 2480 2481 2482 2483 | * *---------------------------------------------------------------------- */ static int SetDoubleFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ | | | 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 | * *---------------------------------------------------------------------- */ static int SetDoubleFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1, NULL, 0); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
2505 2506 2507 2508 2509 2510 2511 | * double-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfDouble( | | | 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 | * double-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfDouble( Tcl_Obj *objPtr) /* Double obj with string rep to update. */ { char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); TclOOM(dst, TCL_DOUBLE_SPACE + 1); Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); |
︙ | ︙ | |||
2546 2547 2548 2549 2550 2551 2552 | * representation. * *---------------------------------------------------------------------- */ int Tcl_GetIntFromObj( | | | | | 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 | * representation. * *---------------------------------------------------------------------- */ int Tcl_GetIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get a int. */ int *intPtr) /* Place to store resulting int. */ { #if (LONG_MAX == INT_MAX) return TclGetLongFromObj(interp, objPtr, (long *) intPtr); #else long l; if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) { |
︙ | ︙ | |||
2617 2618 2619 2620 2621 2622 2623 | * int-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfInt( | | | 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 | * int-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfInt( Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); TclOOM(dst, TCL_INTEGER_SPACE + 1); (void) Tcl_InitStringRep(objPtr, NULL, TclFormatInt(dst, objPtr->internalRep.wideValue)); } |
︙ | ︙ | |||
2649 2650 2651 2652 2653 2654 2655 | * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetLongFromObj( | | | | | 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 | * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetLongFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get a long. */ long *longPtr) /* Place to store resulting long. */ { do { #ifdef TCL_WIDE_INT_IS_LONG if (TclHasInternalRep(objPtr, &tclIntType)) { *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } |
︙ | ︙ | |||
2767 2768 2769 2770 2771 2772 2773 | */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewWideIntObj Tcl_Obj * Tcl_NewWideIntObj( | > | > | | 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 | */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewWideIntObj Tcl_Obj * Tcl_NewWideIntObj( Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewWideIntObj( Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { Tcl_Obj *objPtr; TclNewObj(objPtr); TclSetIntObj(objPtr, wideValue); return objPtr; |
︙ | ︙ | |||
2805 2806 2807 2808 2809 2810 2811 | * None. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_NewWideUIntObj( | | > | 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 | * None. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_NewWideUIntObj( Tcl_WideUInt uwideValue) /* Wide integer used to initialize the new * object. */ { Tcl_Obj *objPtr; TclNewUIntObj(objPtr, uwideValue); return objPtr; } |
︙ | ︙ | |||
2850 2851 2852 2853 2854 2855 2856 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewWideIntObj( | > | > | | 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewWideIntObj( Tcl_WideInt wideValue, /* Wide integer used to initialize the new * object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); TclSetIntObj(objPtr, wideValue); return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewWideIntObj( Tcl_WideInt wideValue, /* Long integer used to initialize the new * object. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { return Tcl_NewWideIntObj(wideValue); } #endif /* TCL_MEM_DEBUG */ |
︙ | ︙ | |||
2897 2898 2899 2900 2901 2902 2903 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetWideIntObj( | | | > | 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetWideIntObj( Tcl_Obj *objPtr, /* Object w. internal rep to init. */ Tcl_WideInt wideValue) /* Wide integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } TclSetIntObj(objPtr, wideValue); |
︙ | ︙ | |||
2928 2929 2930 2931 2932 2933 2934 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetWideUIntObj( | | | > | 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetWideUIntObj( Tcl_Obj *objPtr, /* Object w. internal rep to init. */ Tcl_WideUInt uwideValue) /* Wide integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetWideUIntObj"); } if (uwideValue > WIDE_MAX) { |
︙ | ︙ | |||
2970 2971 2972 2973 2974 2975 2976 | * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetWideIntFromObj( | | | | > | 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 | * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetWideIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* Object from which to get a wide int. */ Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { do { if (TclHasInternalRep(objPtr, &tclIntType)) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } if (TclHasInternalRep(objPtr, &tclDoubleType)) { |
︙ | ︙ | |||
3001 3002 3003 3004 3005 3006 3007 | mp_int big; Tcl_WideUInt value = 0; size_t numBytes; Tcl_WideInt scratch; unsigned char *bytes = (unsigned char *) &scratch; TclUnpackBignum(objPtr, big); | | < | 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 | mp_int big; Tcl_WideUInt value = 0; size_t numBytes; Tcl_WideInt scratch; unsigned char *bytes = (unsigned char *) &scratch; TclUnpackBignum(objPtr, big); if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { *wideIntPtr = (Tcl_WideInt)(-value); return TCL_OK; |
︙ | ︙ | |||
3054 3055 3056 3057 3058 3059 3060 | * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetWideUIntFromObj( | | | | > | 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 | * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetWideUIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* Object from which to get a wide int. */ Tcl_WideUInt *wideUIntPtr) /* Place to store resulting long. */ { do { if (TclHasInternalRep(objPtr, &tclIntType)) { if (objPtr->internalRep.wideValue < 0) { wideUIntOutOfRange: if (interp != NULL) { TclPrintfResult(interp, |
︙ | ︙ | |||
3092 3093 3094 3095 3096 3097 3098 | Tcl_WideUInt scratch; unsigned char *bytes = (unsigned char *) &scratch; TclUnpackBignum(objPtr, big); if (big.sign == MP_NEG) { goto wideUIntOutOfRange; } | | < | 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 | Tcl_WideUInt scratch; unsigned char *bytes = (unsigned char *) &scratch; TclUnpackBignum(objPtr, big); if (big.sign == MP_NEG) { goto wideUIntOutOfRange; } if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideUInt), &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } *wideUIntPtr = (Tcl_WideUInt)value; return TCL_OK; } |
︙ | ︙ | |||
3138 3139 3140 3141 3142 3143 3144 | * conversion will free any old internal representation. * *---------------------------------------------------------------------- */ int TclGetWideBitsFromObj( | | | | | 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 | * conversion will free any old internal representation. * *---------------------------------------------------------------------- */ int TclGetWideBitsFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* Object from which to get a wide int. */ Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */ { do { if (TclHasInternalRep(objPtr, &tclIntType)) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } if (TclHasInternalRep(objPtr, &tclDoubleType)) { |
︙ | ︙ | |||
3202 3203 3204 3205 3206 3207 3208 | * Side effects: * The function may free up any existing internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetSizeIntFromObj( | | | | | 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 | * Side effects: * The function may free up any existing internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetSizeIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get a int. */ Tcl_Size *sizePtr) /* Place to store resulting int. */ { if (sizeof(Tcl_Size) == sizeof(int)) { return TclGetIntFromObj(interp, objPtr, (int *)sizePtr); } else { Tcl_WideInt wide; if (TclGetWideIntFromObj(interp, objPtr, &wide) != TCL_OK) { return TCL_ERROR; |
︙ | ︙ | |||
3473 3474 3475 3476 3477 3478 3479 | objPtr->internalRep.wideValue) != MP_OKAY) { return TCL_ERROR; } return TCL_OK; } if (TclHasInternalRep(objPtr, &tclDoubleType)) { if (interp != NULL) { | | | | | 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 | objPtr->internalRep.wideValue) != MP_OKAY) { return TCL_ERROR; } return TCL_OK; } if (TclHasInternalRep(objPtr, &tclDoubleType)) { if (interp != NULL) { TclPrintfResult(interp, "expected integer but got \"%s\"", TclGetString(objPtr)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL); } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; |
︙ | ︙ | |||
3514 3515 3516 3517 3518 3519 3520 | *---------------------------------------------------------------------- */ int Tcl_GetBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ | | | 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 | *---------------------------------------------------------------------- */ int Tcl_GetBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ void *bignumValue) /* Returned bignum value. */ { return GetBignumFromObj(interp, objPtr, 1, (mp_int *)bignumValue); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
3549 3550 3551 3552 3553 3554 3555 | *---------------------------------------------------------------------- */ int Tcl_TakeBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ | | | 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 | *---------------------------------------------------------------------- */ int Tcl_TakeBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ void *bignumValue) /* Returned bignum value. */ { return GetBignumFromObj(interp, objPtr, 0, (mp_int *)bignumValue); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
3651 3652 3653 3654 3655 3656 3657 | } /* *---------------------------------------------------------------------- * * Tcl_GetNumberFromObj -- * | | | | | | | | | 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 | } /* *---------------------------------------------------------------------- * * Tcl_GetNumberFromObj -- * * Extracts a number (of any possible numeric type) from an object. * * Results: * Whether the extraction worked. The type is stored in the variable * referred to by the typePtr argument, and a pointer to the * representation is stored in the variable referred to by the * clientDataPtr. * * Side effects: * Can allocate thread-specific data for handling the copy-out space for * bignums; this space is shared within a thread. * *---------------------------------------------------------------------- */ int Tcl_GetNumberFromObj( Tcl_Interp *interp, |
︙ | ︙ | |||
3755 3756 3757 3758 3759 3760 3761 | * *---------------------------------------------------------------------- */ #undef Tcl_IncrRefCount void Tcl_IncrRefCount( | | < | < | 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 | * *---------------------------------------------------------------------- */ #undef Tcl_IncrRefCount void Tcl_IncrRefCount( Tcl_Obj *objPtr) /* The object we are registering a reference to. */ { ++(objPtr)->refCount; } /* *---------------------------------------------------------------------- * * Tcl_DecrRefCount -- * * Decrements the reference count of the object. * * Results: * The storage for objPtr may be freed. * *---------------------------------------------------------------------- */ #undef Tcl_DecrRefCount void Tcl_DecrRefCount( Tcl_Obj *objPtr) /* The object we are releasing a reference to. */ { if (objPtr->refCount-- <= 1) { TclFreeObj(objPtr); } } /* |
︙ | ︙ | |||
3800 3801 3802 3803 3804 3805 3806 | * possibly with a refCount of 0. The caller must have previously * incremented the refCount. * *---------------------------------------------------------------------- */ void TclUndoRefCount( | | < | 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 | * possibly with a refCount of 0. The caller must have previously * incremented the refCount. * *---------------------------------------------------------------------- */ void TclUndoRefCount( Tcl_Obj *objPtr) /* The object we are releasing a reference to. */ { if (objPtr->refCount > 0) { --objPtr->refCount; } } /* |
︙ | ︙ | |||
3824 3825 3826 3827 3828 3829 3830 | * *---------------------------------------------------------------------- */ #undef Tcl_IsShared int Tcl_IsShared( | | | 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 | * *---------------------------------------------------------------------- */ #undef Tcl_IsShared int Tcl_IsShared( Tcl_Obj *objPtr) /* The object to test for being shared. */ { return ((objPtr)->refCount > 1); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
3853 3854 3855 3856 3857 3858 3859 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void Tcl_DbIncrRefCount( | | | 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void Tcl_DbIncrRefCount( Tcl_Obj *objPtr, /* The object we are registering a reference * to. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { if (objPtr->refCount == FREEDREFCOUNTFILLER) { |
︙ | ︙ | |||
3884 3885 3886 3887 3888 3889 3890 | if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", | | | | 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 | if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", "incr ref count"); } } # endif /* TCL_THREADS */ ++(objPtr)->refCount; } #else /* !TCL_MEM_DEBUG */ void Tcl_DbIncrRefCount( Tcl_Obj *objPtr, /* The object we are registering a reference * to. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { ++(objPtr)->refCount; } #endif /* TCL_MEM_DEBUG */ |
︙ | ︙ | |||
3926 3927 3928 3929 3930 3931 3932 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void Tcl_DbDecrRefCount( | | | 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void Tcl_DbDecrRefCount( Tcl_Obj *objPtr, /* The object we are releasing a reference * to. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { if (objPtr->refCount == FREEDREFCOUNTFILLER) { |
︙ | ︙ | |||
3957 3958 3959 3960 3961 3962 3963 | if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", | | | | 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 | if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", "decr ref count"); } } # endif /* TCL_THREADS */ if (objPtr->refCount-- <= 1) { TclFreeObj(objPtr); } } #else /* !TCL_MEM_DEBUG */ void Tcl_DbDecrRefCount( Tcl_Obj *objPtr, /* The object we are releasing a reference * to. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { if (objPtr->refCount-- <= 1) { TclFreeObj(objPtr); } |
︙ | ︙ | |||
4003 4004 4005 4006 4007 4008 4009 | * None. * *---------------------------------------------------------------------- */ int Tcl_DbIsShared( | | | 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 | * None. * *---------------------------------------------------------------------- */ int Tcl_DbIsShared( Tcl_Obj *objPtr, /* The object to test for being shared. */ #ifdef TCL_MEM_DEBUG const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ #else TCL_UNUSED(const char *) /*file*/, |
︙ | ︙ | |||
4039 4040 4041 4042 4043 4044 4045 | if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", | | | 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 | if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", "check shared status"); } } # endif /* TCL_THREADS */ #endif /* TCL_MEM_DEBUG */ #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); |
︙ | ︙ | |||
4080 4081 4082 4083 4084 4085 4086 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitObjHashTable( | > | | 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitObjHashTable( Tcl_HashTable *tablePtr) /* Pointer to table record, which is supplied * by the caller. */ { Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, &tclObjHashKeyType); } /* |
︙ | ︙ | |||
4302 4303 4304 4305 4306 4307 4308 | *---------------------------------------------------------------------- */ Tcl_Command Tcl_GetCommandFromObj( Tcl_Interp *interp, /* The interpreter in which to resolve the * command and to report errors. */ | | | 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 | *---------------------------------------------------------------------- */ Tcl_Command Tcl_GetCommandFromObj( Tcl_Interp *interp, /* The interpreter in which to resolve the * command and to report errors. */ Tcl_Obj *objPtr) /* The object containing the command's name. * If the name starts with "::", will be * looked up in global namespace. Else, looked * up first in the current namespace, then in * global namespace. */ { ResolvedCmdName *resPtr; |
︙ | ︙ | |||
4331 4332 4333 4334 4335 4336 4337 | * * If any check fails, then force another conversion to the command type, * to discard the old rep and create a new one. */ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; if (TclHasInternalRep(objPtr, &tclCmdNameType)) { | | | | | | | | | | | | | | | 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 | * * If any check fails, then force another conversion to the command type, * to discard the old rep and create a new one. */ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; if (TclHasInternalRep(objPtr, &tclCmdNameType)) { Command *cmdPtr = resPtr->cmdPtr; if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) && (interp == cmdPtr->nsPtr->interp) && !(cmdPtr->nsPtr->flags & NS_DYING)) { Namespace *refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); if ((resPtr->refNsPtr == NULL) || ((refNsPtr == resPtr->refNsPtr) && (resPtr->refNsId == refNsPtr->nsId) && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) { return (Tcl_Command) cmdPtr; } } } /* * OK, must create a new internal representation (or fail) as any cache we * had is invalid one way or another. */ /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { return NULL; } resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
4438 4439 4440 4441 4442 4443 4444 | } } void TclSetCmdNameObj( Tcl_Interp *interp, /* Points to interpreter containing command * that should be cached in objPtr. */ | | | 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 | } } void TclSetCmdNameObj( Tcl_Interp *interp, /* Points to interpreter containing command * that should be cached in objPtr. */ Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a * CmdName object. */ Command *cmdPtr) /* Points to Command structure that the * CmdName object should refer to. */ { ResolvedCmdName *resPtr; if (TclHasInternalRep(objPtr, &tclCmdNameType)) { |
︙ | ︙ | |||
4478 4479 4480 4481 4482 4483 4484 | * ResolvedSymbol, which may free the Command structure. * *---------------------------------------------------------------------- */ static void FreeCmdNameInternalRep( | | | 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 | * ResolvedSymbol, which may free the Command structure. * *---------------------------------------------------------------------- */ static void FreeCmdNameInternalRep( Tcl_Obj *objPtr) /* CmdName object with internal * representation to free. */ { ResolvedCmdName *resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; /* * Decrement the reference count of the ResolvedCmdName structure. If * there are no more uses, free the ResolvedCmdName structure. |
︙ | ︙ | |||
4526 4527 4528 4529 4530 4531 4532 | * *---------------------------------------------------------------------- */ static void DupCmdNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ | | | 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 | * *---------------------------------------------------------------------- */ static void DupCmdNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { ResolvedCmdName *resPtr = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; resPtr->refCount++; copyPtr->typePtr = &tclCmdNameType; |
︙ | ︙ | |||
4560 4561 4562 4563 4564 4565 4566 | * *---------------------------------------------------------------------- */ static int SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ | | | 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 | * *---------------------------------------------------------------------- */ static int SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { const char *name; Command *cmdPtr; ResolvedCmdName *resPtr; if (interp == NULL) { return TCL_ERROR; |
︙ | ︙ | |||
4647 4648 4649 4650 4651 4652 4653 | /* * Value is a bignum with a refcount of 14, object pointer at 0x12345678, * internal representation 0x45671234:0x98765432, string representation * "1872361827361287" */ | < | | | | 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 | /* * Value is a bignum with a refcount of 14, object pointer at 0x12345678, * internal representation 0x45671234:0x98765432, string representation * "1872361827361287" */ descObj = Tcl_ObjPrintf("value is a %s with a refcount of %" TCL_SIZE_MODIFIER "d," " object pointer at %p", objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", objv[1]->refCount, objv[1]); if (objv[1]->typePtr) { if (TclHasInternalRep(objv[1], &tclDoubleType)) { Tcl_AppendPrintfToObj(descObj, ", internal representation %g", objv[1]->internalRep.doubleValue); } else { Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p", (void *) objv[1]->internalRep.twoPtrValue.ptr1, (void *) objv[1]->internalRep.twoPtrValue.ptr2); } } if (objv[1]->bytes) { Tcl_AppendToObj(descObj, ", string representation \"", -1); Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, 16, "..."); Tcl_AppendToObj(descObj, "\"", -1); } else { Tcl_AppendToObj(descObj, ", no string representation", -1); } Tcl_SetObjResult(interp, descObj); return TCL_OK; |
︙ | ︙ |
Changes to generic/tclParse.c.
︙ | ︙ | |||
201 202 203 204 205 206 207 | Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the script consists of all bytes up to the * first null character. */ int nested, /* Non-zero means this is a nested command: * close bracket should be considered a * command terminator. If zero, then close * bracket has no special meaning. */ | > | | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 | Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the script consists of all bytes up to the * first null character. */ int nested, /* Non-zero means this is a nested command: * close bracket should be considered a * command terminator. If zero, then close * bracket has no special meaning. */ Tcl_Parse *parsePtr) /* Structure to fill in with information about * the parsed command; any previous * information in the structure is ignored. */ { const char *src; /* Points to current character in the * command. */ char type; /* Result returned by CHAR_TYPE(*src). */ Tcl_Token *tokenPtr; /* Pointer to token being filled in. */ |
︙ | ︙ | |||
523 524 525 526 527 528 529 | } else if ((tokenPtr->numComponents == 1) && (tokenPtr[1].type == TCL_TOKEN_TEXT)) { tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } /* Parse the whitespace between words. */ | | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | } else if ((tokenPtr->numComponents == 1) && (tokenPtr[1].type == TCL_TOKEN_TEXT)) { tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } /* Parse the whitespace between words. */ scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); src += scanned; numBytes -= scanned; } } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 | * None. * *---------------------------------------------------------------------- */ static int ParseTokens( | | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 | * None. * *---------------------------------------------------------------------- */ static int ParseTokens( const char *src, /* First character to parse. */ Tcl_Size numBytes, /* Max number of bytes to scan. */ int mask, /* Specifies when to stop parsing. The parse * stops at the first unquoted character whose * CHAR_TYPE contains any of the bits in * mask. */ int flags, /* OR-ed bits indicating what substitutions to * perform: TCL_SUBST_COMMANDS, |
︙ | ︙ | |||
1381 1382 1383 1384 1385 1386 1387 | src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; ch = *src; | | | < < | < < < | | | 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 | src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; ch = *src; while (numBytes && (braceCount>0 || ch != '}')) { switch (ch) { case '{': braceCount++; break; case '}': braceCount--; break; case '\\': /* if 2 or more left, consume 2, else consume * just the \ and let it run into the end */ if (numBytes > 1) { src++; numBytes--; } } numBytes--; src++; ch= *src; } if (numBytes == 0) { if (parsePtr->interp != NULL) { TclSetResult(parsePtr->interp, "missing close-brace for variable name"); } parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE; parsePtr->term = tokenPtr->start-1; parsePtr->incomplete = 1; goto error; } tokenPtr->size = src - tokenPtr->start; tokenPtr[-1].size = src - tokenPtr[-1].start; parsePtr->numTokens++; src++; |
︙ | ︙ | |||
1526 1527 1528 1529 1530 1531 1532 | * *---------------------------------------------------------------------- */ const char * Tcl_ParseVar( Tcl_Interp *interp, /* Context for looking up variable. */ | | | 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 | * *---------------------------------------------------------------------- */ const char * Tcl_ParseVar( Tcl_Interp *interp, /* Context for looking up variable. */ const char *start, /* Start of variable substitution. First * character must be "$". */ const char **termPtr) /* If non-NULL, points to word to fill in with * character just after last one in the * variable specifier. */ { Tcl_Obj *objPtr; int code; |
︙ | ︙ | |||
1614 1615 1616 1617 1618 1619 1620 | Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* Start of string enclosed in braces. The * first character must be {'. */ Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the string consists of all bytes up to the * first null character. */ | > | | 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 | Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* Start of string enclosed in braces. The * first character must be {'. */ Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr, /* Structure to fill in with information about * the string. */ int append, /* Non-zero means append tokens to existing * information in parsePtr; zero means ignore * existing tokens in parsePtr and * reinitialize it. */ const char **termPtr) /* If non-NULL, points to word in which to * store a pointer to the character just after |
︙ | ︙ | |||
1813 1814 1815 1816 1817 1818 1819 | Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* Start of the quoted string. The first * character must be '"'. */ Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the string consists of all bytes up to the * first null character. */ | > | | 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 | Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* Start of the quoted string. The first * character must be '"'. */ Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr, /* Structure to fill in with information about * the string. */ int append, /* Non-zero means append tokens to existing * information in parsePtr; zero means ignore * existing tokens in parsePtr and * reinitialize it. */ const char **termPtr) /* If non-NULL, points to word in which to * store a pointer to the character just after |
︙ | ︙ |
Changes to generic/tclPathObj.c.
︙ | ︙ | |||
36 37 38 39 40 41 42 | /* * Define the 'path' object type, which Tcl uses to represent file paths * internally. */ static const Tcl_ObjType fsPathType = { | | | | | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | /* * Define the 'path' object type, which Tcl uses to represent file paths * internally. */ static const Tcl_ObjType fsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ SetFsPathFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; /* * struct FsPath -- * * Internal representation of a Tcl_Obj of fsPathType |
︙ | ︙ | |||
86 87 88 89 90 91 92 | /* * Define some macros to give us convenient access to path-object specific * fields. */ #define PATHOBJ(pathPtr) ((FsPath *) (TclFetchInternalRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | /* * Define some macros to give us convenient access to path-object specific * fields. */ #define PATHOBJ(pathPtr) ((FsPath *) (TclFetchInternalRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) #define SETPATHOBJ(pathPtr,fsPathPtr) \ do { \ Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \ ir.twoPtrValue.ptr2 = NULL; \ Tcl_StoreInternalRep((pathPtr), &fsPathType, &ir); \ } while (0) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) |
︙ | ︙ | |||
151 152 153 154 155 156 157 | if (zipVolumeLen) { /* * NOTE: file normalization for zipfs is very specific to * format of zipfs volume being of the form //xxx:/ */ dirSep += zipVolumeLen-1; /* Start parse after : */ } else if (tclPlatform == TCL_PLATFORM_WINDOWS) { | | | | | | | | | | 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 | if (zipVolumeLen) { /* * NOTE: file normalization for zipfs is very specific to * format of zipfs volume being of the form //xxx:/ */ dirSep += zipVolumeLen-1; /* Start parse after : */ } else if (tclPlatform == TCL_PLATFORM_WINDOWS) { if ( (dirSep[0] == '/' || dirSep[0] == '\\') && (dirSep[1] == '/' || dirSep[1] == '\\') && (dirSep[2] == '?') && (dirSep[3] == '/' || dirSep[3] == '\\')) { /* NT extended path */ dirSep += 4; if ( (dirSep[0] == 'U' || dirSep[0] == 'u') && (dirSep[1] == 'N' || dirSep[1] == 'n') && (dirSep[2] == 'C' || dirSep[2] == 'c') && (dirSep[3] == '/' || dirSep[3] == '\\')) { /* NT extended UNC path */ dirSep += 4; } } if (dirSep[0] != 0 && dirSep[1] == ':' && (dirSep[2] == '/' || dirSep[2] == '\\')) { /* Do nothing */ |
︙ | ︙ | |||
722 723 724 725 726 727 728 | * Tcl_FSSplitPath preserves the "~", but this code computes the * actual full path name, if we had just a single component. */ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); | | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 | * Tcl_FSSplitPath preserves the "~", but this code computes the * actual full path name, if we had just a single component. */ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); if (portion == TCL_PATH_TAIL) { /* * Return the last component, unless it is the only component, and * it is the root of an absolute path. */ if ((splitElements > 0) && ((splitElements > 1) || (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) { |
︙ | ︙ | |||
1050 1051 1052 1053 1054 1055 1056 | noQuickReturn: if (res == NULL) { TclNewObj(res); } ptr = TclGetStringFromObj(res, &length); | | | | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 | noQuickReturn: if (res == NULL) { TclNewObj(res); } ptr = TclGetStringFromObj(res, &length); /* * A NULL value for fsPtr at this stage basically means we're trying * to join a relative path onto something which is also relative (or * empty). There's nothing particularly wrong with that. */ if (*strElt == '\0') { continue; } |
︙ | ︙ | |||
2343 2344 2345 2346 2347 2348 2349 | * Memory may be allocated. * *--------------------------------------------------------------------------- */ static void UpdateStringOfFsPath( | | | 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 | * Memory may be allocated. * *--------------------------------------------------------------------------- */ static void UpdateStringOfFsPath( Tcl_Obj *pathPtr) /* path obj with string rep to update. */ { FsPath *fsPathPtr = PATHOBJ(pathPtr); Tcl_Size cwdLen; Tcl_Obj *copy; if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) { if (fsPathPtr->translatedPathPtr == NULL) { |
︙ | ︙ | |||
2447 2448 2449 2450 2451 2452 2453 | } /* *---------------------------------------------------------------------- * * MakeTildeRelativePath -- * | | | | | | | | | | > | | 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 | } /* *---------------------------------------------------------------------- * * MakeTildeRelativePath -- * * Returns a path relative to the home directory of a user. * Note there is a difference between not specifying a user and * explicitly specifying the current user. This mimics Tcl8's tilde * expansion. * * The subPath argument is joined to the expanded home directory * as in Tcl_JoinPath. This means if it is not relative, it will * returned as the result with the home directory only checked * for user name validity. * * Results: * Returns TCL_OK on success with home directory path in *dsPtr * and TCL_ERROR on failure with error message in interp if non-NULL. * *---------------------------------------------------------------------- */ int MakeTildeRelativePath( Tcl_Interp *interp, /* May be NULL. Only used for error messages */ const char *user, /* User name. NULL -> current user */ const char *subPath, /* Rest of path. May be NULL */ Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be * freed on success */ { const char *dir; Tcl_DString dirString; Tcl_DStringInit(dsPtr); Tcl_DStringInit(&dirString); if (user == NULL || user[0] == 0) { /* No user name specified -> current user */ dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { TclSetResult(interp, "couldn't find HOME environment variable to expand path"); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "HOMELESS", (void *)NULL); } return TCL_ERROR; } } else { /* User name specified - ~user */ dir = TclpGetUserHome(user, &dirString); if (dir == NULL) { if (interp != NULL) { TclPrintfResult(interp, "user \"%s\" doesn't exist", user); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", (void *)NULL); } return TCL_ERROR; } } if (subPath) { const char *parts[2]; parts[0] = dir; parts[1] = subPath; Tcl_JoinPath(2, parts, dsPtr); |
︙ | ︙ | |||
2524 2525 2526 2527 2528 2529 2530 | *---------------------------------------------------------------------- * * TclGetHomeDirObj -- * * Wrapper around MakeTildeRelativePath. See that function. * * Results: | | | | | | | | 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 | *---------------------------------------------------------------------- * * TclGetHomeDirObj -- * * Wrapper around MakeTildeRelativePath. See that function. * * Results: * Returns a Tcl_Obj containing the home directory of a user * or NULL on failure with error message in interp if non-NULL. * *---------------------------------------------------------------------- */ Tcl_Obj * TclGetHomeDirObj( Tcl_Interp *interp, /* May be NULL. Only used for error messages */ const char *user) /* User name. NULL -> current user */ { Tcl_DString dirString; if (MakeTildeRelativePath(interp, user, NULL, &dirString) != TCL_OK) { return NULL; } return Tcl_DStringToObj(&dirString); } /* *---------------------------------------------------------------------- * * TclResolveTildePath -- * * If the passed path is begins with a tilde, does tilde resolution * and returns a Tcl_Obj containing the resolved path. If the tilde * component cannot be resolved, returns NULL. If the path does not * begin with a tilde, returns as is. * * Results: * Returns a Tcl_Obj with resolved path. This may be a new Tcl_Obj * with ref count 0 or that pathObj that was passed in without its * ref count modified. * Returns NULL if the path begins with a ~ that cannot be resolved * and stores an error message in interp if non-NULL. * *---------------------------------------------------------------------- */ Tcl_Obj * TclResolveTildePath( Tcl_Interp *interp, /* May be NULL. Only used for error messages */ Tcl_Obj *pathObj) { const char *path; Tcl_Size len; Tcl_Size split; Tcl_DString resolvedPath; |
︙ | ︙ | |||
2585 2586 2587 2588 2589 2590 2591 | * split becomes value 1 for '~/...' as well as for '~'. Note on * Windows FindSplitPos will implicitly check for '\' as separator * in addition to what is passed. */ split = FindSplitPos(path, '/'); if (split == 1) { | | | | | | | | | 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 | * split becomes value 1 for '~/...' as well as for '~'. Note on * Windows FindSplitPos will implicitly check for '\' as separator * in addition to what is passed. */ split = FindSplitPos(path, '/'); if (split == 1) { /* No user name specified -> current user */ if (MakeTildeRelativePath(interp, NULL, path[1] ? 2 + path : NULL, &resolvedPath) != TCL_OK) { return NULL; } } else { /* User name specified - ~user */ const char *expandedUser; Tcl_DString userName; Tcl_DStringInit(&userName); Tcl_DStringAppend(&userName, path+1, split-1); expandedUser = Tcl_DStringValue(&userName); /* path[split] is / or \0 */ if (MakeTildeRelativePath(interp, expandedUser, path[split] ? &path[split+1] : NULL, &resolvedPath) != TCL_OK) { Tcl_DStringFree(&userName); return NULL; |
︙ | ︙ | |||
2620 2621 2622 2623 2624 2625 2626 | * * TclResolveTildePathList -- * * Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing * the paths with any ~-prefixed paths resolved. * * Empty strings and ~-prefixed paths that cannot be resolved are | | | | 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 | * * TclResolveTildePathList -- * * Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing * the paths with any ~-prefixed paths resolved. * * Empty strings and ~-prefixed paths that cannot be resolved are * removed from the returned list. * * The trailing components of the path are returned verbatim. No * processing is done on them. Moreover, no assumptions should be * made about the separators in the returned path. They may be / * or native. Appropriate path manipulations functions should be * used by caller if desired. * * Results: * Returns a Tcl_Obj with resolved paths. This may be a new Tcl_Obj with |
︙ | ︙ | |||
2647 2648 2649 2650 2651 2652 2653 | Tcl_Obj **objv; Tcl_Size objc; Tcl_Size i; Tcl_Obj *resolvedPaths; const char *path; if (pathsObj == NULL) { | | | | | | | | | | | 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 | Tcl_Obj **objv; Tcl_Size objc; Tcl_Size i; Tcl_Obj *resolvedPaths; const char *path; if (pathsObj == NULL) { return NULL; } if (Tcl_ListObjGetElements(NULL, pathsObj, &objc, &objv) != TCL_OK) { return NULL; /* Not a list */ } /* * Figure out if any paths need resolving to avoid unnecessary allocations. */ for (i = 0; i < objc; ++i) { path = Tcl_GetString(objv[i]); if (path[0] == '~') { break; /* At least one path needs resolution */ } } if (i == objc) { return pathsObj; /* No paths needed to be resolved */ } resolvedPaths = Tcl_NewListObj(objc, NULL); for (i = 0; i < objc; ++i) { Tcl_Obj *resolvedPath; path = Tcl_GetString(objv[i]); if (path[0] == 0) { continue; /* Skip empty strings */ } resolvedPath = TclResolveTildePath(NULL, objv[i]); if (resolvedPath) { /* Paths that cannot be resolved are skipped */ Tcl_ListObjAppendElement(NULL, resolvedPaths, resolvedPath); } } |
︙ | ︙ |
Changes to generic/tclPipe.c.
︙ | ︙ | |||
1011 1012 1013 1014 1015 1016 1017 | *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenCommandChannel( Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be * NULL. */ | | | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 | *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenCommandChannel( Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be * NULL. */ Tcl_Size argc, /* How many arguments. */ const char **argv, /* Array of arguments for command pipe. */ int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT, * TCL_STDERR, and TCL_ENFORCE_MODE. */ { TclFile *inPipePtr, *outPipePtr, *errFilePtr; TclFile inPipe, outPipe, errFile; Tcl_Size numPids; |
︙ | ︙ |
Changes to generic/tclPkg.c.
︙ | ︙ | |||
92 93 94 95 96 97 98 | static int SomeRequirementSatisfied(char *havei, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); | | < | < | < | < | < | < < | < | < | < | | | | | | | 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 | static int SomeRequirementSatisfied(char *havei, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); static int PkgRequireCore(void *data[], Tcl_Interp *interp, int result); static int PkgRequireCoreFinal(void *data[], Tcl_Interp *interp, int result); static int PkgRequireCoreCleanup(void *data[], Tcl_Interp *interp, int result); static int PkgRequireCoreStep1(void *data[], Tcl_Interp *interp, int result); static int PkgRequireCoreStep2(void *data[], Tcl_Interp *interp, int result); static int TclNRPkgRequireProc(void *clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static int SelectPackage(void *data[], Tcl_Interp *interp, int result); static int SelectPackageFinal(void *data[], Tcl_Interp *interp, int result); static int TclNRPackageObjCmdCleanup(void *data[], Tcl_Interp *interp, int result); /* * Helper macros. */ #define DupBlock(v,s,len) \ ((v) = (char *)Tcl_Alloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ size_t local__len = strlen(s) + 1; \ DupBlock((v),(s),local__len); \ } while (0) /* *---------------------------------------------------------------------- * * Tcl_PkgProvide / Tcl_PkgProvideEx -- * |
︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 | TclNewObj(resultObj); tablePtr = &iPtr->packageTable; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { pkgPtr = (Package *)Tcl_GetHashValue(hPtr); if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { | | | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 | TclNewObj(resultObj); tablePtr = &iPtr->packageTable; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { pkgPtr = (Package *)Tcl_GetHashValue(hPtr); if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj( (char *)Tcl_GetHashKey(tablePtr, hPtr), -1)); } } Tcl_SetObjResult(interp, resultObj); } break; case PKG_PRESENT: { |
︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 | objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, | | | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 | objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); Tcl_NRAddCallback(interp, PkgRequireCore, (void *) argv3, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; } else { Tcl_Obj *const *newobjv = objv + 3; |
︙ | ︙ | |||
1391 1392 1393 1394 1395 1396 1397 | */ Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, | | | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 | */ Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); Tcl_NRAddCallback(interp, PkgRequireCore, (void *) argv2, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; } break; case PKG_UNKNOWN: { |
︙ | ︙ |
Changes to generic/tclPosixStr.c.
︙ | ︙ | |||
520 521 522 523 524 525 526 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_ErrnoMsg( | | | 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_ErrnoMsg( int err) /* Error number (such as in errno variable). */ { switch (err) { #if defined(E2BIG) && (!defined(EOVERFLOW) || (E2BIG != EOVERFLOW)) case E2BIG: return "argument list too long"; #endif #ifdef EACCES case EACCES: return "permission denied"; |
︙ | ︙ | |||
1018 1019 1020 1021 1022 1023 1024 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_SignalId( | | | 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_SignalId( int sig) /* Number of signal. */ { switch (sig) { #ifdef SIGABRT case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM case SIGALRM: return "SIGALRM"; |
︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_SignalMsg( | | | 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_SignalMsg( int sig) /* Number of signal. */ { switch (sig) { #ifdef SIGABRT case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM case SIGALRM: return "alarm clock"; |
︙ | ︙ |
Changes to generic/tclPreserve.c.
︙ | ︙ | |||
17 18 19 20 21 22 23 | /* * The following data structure is used to keep track of all the Tcl_Preserve * calls that are still in effect. It grows as needed to accommodate any * number of calls in effect. */ typedef struct { | | | < | | 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 | /* * The following data structure is used to keep track of all the Tcl_Preserve * calls that are still in effect. It grows as needed to accommodate any * number of calls in effect. */ typedef struct { void *clientData; /* Address of preserved block. */ size_t refCount; /* Number of Tcl_Preserve calls in effect for * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was * called while a Tcl_Preserve call was in * effect, so the structure must be freed when * refCount becomes zero. */ Tcl_FreeProc *freeProc; /* Function to call to free. */ } Reference; /* * Global data structures used to hold the list of preserved data references. * These variables are protected by "preserveMutex". */ static Reference *refArray = NULL; /* First in array of references. */ static size_t spaceAvl = 0; /* Total number of structures available at * *firstRefPtr. */ static size_t inUse = 0; /* Count of structures currently in use in * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ #define INITIAL_SIZE 2 /* Initial number of reference slots to make */ /* * The following data structure is used to keep track of whether an arbitrary |
︙ | ︙ | |||
114 115 116 117 118 119 120 | * until at least the matching call to Tcl_Release. * *---------------------------------------------------------------------- */ void Tcl_Preserve( | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | * until at least the matching call to Tcl_Release. * *---------------------------------------------------------------------- */ void Tcl_Preserve( void *clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; size_t i; /* * See if there is already a reference for this pointer. If so, just * increment its reference count. |
︙ | ︙ | |||
177 178 179 180 181 182 183 | * call to Tcl_Preserve is still in effect, the block of memory is freed. * *---------------------------------------------------------------------- */ void Tcl_Release( | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | * call to Tcl_Preserve is still in effect, the block of memory is freed. * *---------------------------------------------------------------------- */ void Tcl_Release( void *clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; size_t i; Tcl_MutexLock(&preserveMutex); for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) { int mustFree; |
︙ | ︙ | |||
256 257 258 259 260 261 262 | * Ptr may be released by calling free(). * *---------------------------------------------------------------------- */ void Tcl_EventuallyFree( | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 | * Ptr may be released by calling free(). * *---------------------------------------------------------------------- */ void Tcl_EventuallyFree( void *clientData, /* Pointer to malloc'ed block of memory. */ Tcl_FreeProc *freeProc) /* Function to actually do free. */ { Reference *refPtr; size_t i; /* * See if there is a reference for this pointer. If so, set its "mustFree" |
︙ | ︙ |
Changes to generic/tclProc.c.
︙ | ︙ | |||
891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 | int TclNRUplevelObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; CmdFrame *invoker = NULL; int word = 0; int result; CallFrame *savedVarFramePtr, *framePtr; Tcl_Obj *objPtr; if (objc < 2) { | > | | | | | | 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 | int TclNRUplevelObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; CmdFrame *invoker = NULL; int word = 0; int result; CallFrame *savedVarFramePtr, *framePtr; Tcl_Obj *objPtr; if (objc < 2) { /* to do * simplify things by interpreting the argument as a command when there * is only one argument. This requires a TIP since currently a single * argument is interpreted as a level indicator if possible. */ uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; } else if (!TclHasStringRep(objv[1]) && objc == 2) { int status; Tcl_Size llength; status = TclListObjLength(interp, objv[1], &llength); |
︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 | l++; } TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); | | < | 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 | l++; } TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); const char *a[6]; Tcl_Size i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; |
︙ | ︙ | |||
2096 2097 2098 2099 2100 2101 2102 | * procedure completes. * *---------------------------------------------------------------------- */ void TclProcDeleteProc( | | | 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 | * procedure completes. * *---------------------------------------------------------------------- */ void TclProcDeleteProc( void *clientData) /* Procedure to be deleted. */ { Proc *procPtr = (Proc *)clientData; if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } } |
︙ | ︙ |
Changes to generic/tclProcess.c.
︙ | ︙ | |||
36 37 38 39 40 41 42 | } ProcessInfo; static Tcl_HashTable infoTablePerPid; static Tcl_HashTable infoTablePerResolvedPid; static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(infoTablesMutex) | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | } ProcessInfo; static Tcl_HashTable infoTablePerPid; static Tcl_HashTable infoTablePerResolvedPid; static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(infoTablesMutex) /* * Prototypes for functions defined later in this file: */ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, Tcl_Size resolvedPid); static void FreeProcessInfo(ProcessInfo *info); static int RefreshProcessInfo(ProcessInfo *info, int options); |
︙ | ︙ |
Changes to generic/tclRegexp.c.
︙ | ︙ | |||
99 100 101 102 103 104 105 | /* * The regular expression Tcl object type. This serves as a cache of the * compiled form of the regular expression. */ const Tcl_ObjType tclRegexpType = { | | | | | | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | /* * The regular expression Tcl object type. This serves as a cache of the * compiled form of the regular expression. */ const Tcl_ObjType tclRegexpType = { "regexp", /* name */ FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetRegexpFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; #define RegexpSetInternalRep(objPtr, rePtr) \ do { \ Tcl_ObjInternalRep ir; \ (rePtr)->refCount++; \ |
︙ | ︙ |
Changes to generic/tclResult.c.
︙ | ︙ | |||
437 438 439 440 441 442 443 | * the interpreter. * *---------------------------------------------------------------------- */ static void ResetObjResult( | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | * the interpreter. * *---------------------------------------------------------------------- */ static void ResetObjResult( Interp *iPtr) /* Points to the interpreter whose result * object should be reset. */ { Tcl_Obj *objResultPtr = iPtr->objResultPtr; if (Tcl_IsShared(objResultPtr)) { TclDecrRefCount(objResultPtr); TclNewObj(objResultPtr); |
︙ | ︙ | |||
547 548 549 550 551 552 553 | } /* *---------------------------------------------------------------------- * * Tcl_GetErrorLine -- * | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_GetErrorLine -- * * Returns the line number associated with the current error. * *---------------------------------------------------------------------- */ int Tcl_GetErrorLine( Tcl_Interp *interp) { return ((Interp *) interp)->errorLine; } /* *---------------------------------------------------------------------- * * Tcl_SetErrorLine -- * * Sets the line number associated with the current error. * *---------------------------------------------------------------------- */ void Tcl_SetErrorLine( Tcl_Interp *interp, |
︙ | ︙ | |||
712 713 714 715 716 717 718 | if (code == TCL_ERROR) { if (iPtr->errorInfo) { Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | if (code == TCL_ERROR) { if (iPtr->errorInfo) { Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { Tcl_Size length; (void)TclGetStringFromObj(valuePtr, &length); if (length) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; } } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], &valuePtr); if (valuePtr != NULL) { Tcl_Size len, valueObjc; Tcl_Obj **valueObjv; if (Tcl_IsShared(iPtr->errorStack)) { Tcl_Obj *newObj; newObj = Tcl_DuplicateObj(iPtr->errorStack); Tcl_DecrRefCount(iPtr->errorStack); Tcl_IncrRefCount(newObj); iPtr->errorStack = newObj; } /* * List extraction done after duplication to avoid moving the rug * if someone does [return -errorstack [info errorstack]] */ if (TclListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { return TCL_ERROR; } iPtr->resetErrorStack = 0; TclListObjLength(interp, iPtr->errorStack, &len); /* * Reset while keeping the list internalrep as much as possible. */ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv); } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr); if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } else { Tcl_SetErrorCode(interp, "NONE", (void *)NULL); } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr); if (valuePtr != NULL) { TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine); } } if (level != 0) { iPtr->returnLevel = level; iPtr->returnCode = code; |
︙ | ︙ | |||
870 871 872 873 874 875 876 | /* * Check for bogus -code value. */ Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); if (valuePtr != NULL) { if (TclGetCompletionCodeFromObj(interp, valuePtr, | | | 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 | /* * Check for bogus -code value. */ Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); if (valuePtr != NULL) { if (TclGetCompletionCodeFromObj(interp, valuePtr, &code) == TCL_ERROR) { goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]); } /* * Check for bogus -level value. |
︙ | ︙ | |||
936 937 938 939 940 941 942 | * Value is not a list, which is illegal for -errorstack. */ TclPrintfResult(interp, "bad -errorstack value: expected a list but got \"%s\"", TclGetString(valuePtr)); Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", | | | | | | | | | | 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 | * Value is not a list, which is illegal for -errorstack. */ TclPrintfResult(interp, "bad -errorstack value: expected a list but got \"%s\"", TclGetString(valuePtr)); Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", (void *)NULL); goto error; } if (length % 2) { /* * Errorstack must always be an even-sized list */ TclPrintfResult(interp, "forbidden odd-sized list for -errorstack: \"%s\"", TclGetString(valuePtr)); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ODDSIZEDLIST_ERRORSTACK", (void *)NULL); goto error; } } /* * Convert [return -code return -level X] to [return -code ok -level X+1] */ if (code == TCL_RETURN) { |
︙ | ︙ | |||
1030 1031 1032 1033 1034 1035 1036 | Tcl_NewWideIntObj(result)); Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL], Tcl_NewWideIntObj(0)); } if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, ""); | | | 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 | Tcl_NewWideIntObj(result)); Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL], Tcl_NewWideIntObj(0)); } if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, ""); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack); } if (iPtr->errorCode) { Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode); } if (iPtr->errorInfo) { Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE], |
︙ | ︙ |
Changes to generic/tclScan.c.
︙ | ︙ | |||
13 14 15 16 17 18 19 | #include "tclTomMath.h" #include <assert.h> /* * Flag values used by Tcl_ScanObjCmd. */ | | | | | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | #include "tclTomMath.h" #include <assert.h> /* * Flag values used by Tcl_ScanObjCmd. */ #define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ #define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ #define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ #define SCAN_WIDTH 0x8 /* A width value was supplied. */ #define SCAN_LONGER 0x400 /* Asked for a wide value. */ #define SCAN_BIG 0x800 /* Asked for a bignum value. */ /* * The following structure contains the information associated with a * character set. */ typedef struct { |
︙ | ︙ | |||
360 361 362 363 364 365 366 | /* Note >=, not >, to leave room for a nul */ if (ull >= TCL_SIZE_MAX) { TclPrintfResult(interp, "specified field width %" TCL_LL_MODIFIER "u exceeds limit %" TCL_SIZE_MODIFIER "d.", ull, (Tcl_Size)TCL_SIZE_MAX-1); Tcl_SetErrorCode( | | | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 | /* Note >=, not >, to leave room for a nul */ if (ull >= TCL_SIZE_MAX) { TclPrintfResult(interp, "specified field width %" TCL_LL_MODIFIER "u exceeds limit %" TCL_SIZE_MODIFIER "d.", ull, (Tcl_Size)TCL_SIZE_MAX-1); Tcl_SetErrorCode( interp, "TCL", "FORMAT", "WIDTHLIMIT", (void *)NULL); goto error; } flags |= SCAN_WIDTH; format += TclUtfToUniChar(format, &ch); } /* |
︙ | ︙ |
Changes to generic/tclStrToD.c.
︙ | ︙ | |||
67 68 69 70 71 72 73 | /* * Sun ProC needs sunmath for rounding control on x86 like gcc above. */ # elif defined(__sun) # include <sunmath.h> # define TCL_IEEE_DOUBLE_ROUNDING_DECL # define TCL_IEEE_DOUBLE_ROUNDING \ | | | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | /* * Sun ProC needs sunmath for rounding control on x86 like gcc above. */ # elif defined(__sun) # include <sunmath.h> # define TCL_IEEE_DOUBLE_ROUNDING_DECL # define TCL_IEEE_DOUBLE_ROUNDING \ ieee_flags("set","precision","double",NULL) # define TCL_DEFAULT_DOUBLE_ROUNDING \ ieee_flags("clear","precision",NULL,NULL) # endif #endif /* * Other platforms are assumed to always operate in full IEEE mode, so we make * the macros to go in and out of that mode do nothing. */ |
︙ | ︙ | |||
1692 1693 1694 1695 1696 1697 1698 | * With gcc on x86, the floating point rounding mode is double-extended. * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of 1 * ulp, so we need to change rounding mode to 53-bits. We also make * 'retval' volatile, so that it doesn't get promoted to a register. */ | | | 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 | * With gcc on x86, the floating point rounding mode is double-extended. * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of 1 * ulp, so we need to change rounding mode to 53-bits. We also make * 'retval' volatile, so that it doesn't get promoted to a register. */ volatile double retval; /* Value of the number. */ /* * Test for zero significand, which requires explicit construction * of -0.0. (Unary minus returns a positive zero.) */ if (significand == 0) { return copysign(0.0, -signum); |
︙ | ︙ | |||
2258 2259 2260 2261 2262 2263 2264 | NormalizeRightward( Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */ { int rv = 0; Tcl_WideUInt w = *wPtr; if (!(w & (Tcl_WideUInt) 0xFFFFFFFF)) { | | < | < | < | < | < | < | 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 | NormalizeRightward( Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */ { int rv = 0; Tcl_WideUInt w = *wPtr; if (!(w & (Tcl_WideUInt) 0xFFFFFFFF)) { w >>= 32; rv += 32; } if (!(w & (Tcl_WideUInt) 0xFFFF)) { w >>= 16; rv += 16; } if (!(w & (Tcl_WideUInt) 0xFF)) { w >>= 8; rv += 8; } if (!(w & (Tcl_WideUInt) 0xF)) { w >>= 4; rv += 4; } if (!(w & 0x3)) { w >>= 2; rv += 2; } if (!(w & 0x1)) { w >>= 1; ++rv; } *wPtr = w; return rv; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
2307 2308 2309 2310 2311 2312 2313 | RequiredPrecision( Tcl_WideUInt w) /* Number to interrogate. */ { int rv; unsigned long wi; if (w & ((Tcl_WideUInt) 0xFFFFFFFF << 32)) { | | < | < | < | < | < | < | < | 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 | RequiredPrecision( Tcl_WideUInt w) /* Number to interrogate. */ { int rv; unsigned long wi; if (w & ((Tcl_WideUInt) 0xFFFFFFFF << 32)) { wi = (unsigned long) (w >> 32); rv = 32; } else { wi = (unsigned long) w; rv = 0; } if (wi & 0xFFFF0000) { wi >>= 16; rv += 16; } if (wi & 0xFF00) { wi >>= 8; rv += 8; } if (wi & 0xF0) { wi >>= 4; rv += 4; } if (wi & 0xC) { wi >>= 2; rv += 2; } if (wi & 0x2) { wi >>= 1; ++rv; } if (wi & 0x1) { ++rv; } return rv; } |
︙ | ︙ | |||
2661 2662 2663 2664 2665 2666 2667 | * one too high. * *---------------------------------------------------------------------- */ static inline void SetPrecisionLimits( | | | 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 | * one too high. * *---------------------------------------------------------------------- */ static inline void SetPrecisionLimits( int flags, /* Type of conversion: TCL_DD_SHORTEST, * TCL_DD_E_FMT, TCL_DD_F_FMT. */ int k, /* Floor(log10(number to convert)) */ int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be * adjusted if needed). */ int *iPtr, /* OUT: Maximum number of digits to return. */ int *iLimPtr, /* OUT: Number of digits of significance if * the bignum method is used.*/ |
︙ | ︙ | |||
3157 3158 3159 3160 3161 3162 3163 | /* * Adjust if the logarithm was guessed wrong. */ if (b < S) { b = 10 * b; | | < < | 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 | /* * Adjust if the logarithm was guessed wrong. */ if (b < S) { b = 10 * b; ++m2plus; ++m2minus; ++m5; ilim = ilim1; --k; } /* * Compute roundoff ranges. */ |
︙ | ︙ | |||
3537 3538 3539 3540 3541 3542 3543 | /* * Adjust if the logarithm was guessed wrong. */ if ((err == MP_OKAY) && (b.used <= sd)) { err = mp_mul_d(&b, 10, &b); | | < < | 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 | /* * Adjust if the logarithm was guessed wrong. */ if ((err == MP_OKAY) && (b.used <= sd)) { err = mp_mul_d(&b, 10, &b); ++m2plus; ++m2minus; ++m5; ilim = ilim1; --k; } /* * mminus = 5**m5 * 2**m2minus * mplus = 5**m5 * 2**m2plus |
︙ | ︙ | |||
3579 3580 3581 3582 3583 3584 3585 | if (b.used <= sd) { digit = 0; } else { digit = b.dp[sd]; if (b.used > sd+1 || digit >= 10) { Tcl_Panic("wrong digit!"); } | | < | 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 | if (b.used <= sd) { digit = 0; } else { digit = b.dp[sd]; if (b.used > sd+1 || digit >= 10) { Tcl_Panic("wrong digit!"); } --b.used; mp_clamp(&b); } /* * Does the current digit put us on the low side of the exact value * but within within roundoff of being exact? */ |
︙ | ︙ | |||
4556 4557 4558 4559 4560 4561 4562 | int len = i; /* * Reduce numerator and denominator to lowest terms. */ if (b2 >= s2 && s2 > 0) { | | < | < | 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 | int len = i; /* * Reduce numerator and denominator to lowest terms. */ if (b2 >= s2 && s2 > 0) { b2 -= s2; s2 = 0; } else if (s2 >= b2 && b2 > 0) { s2 -= b2; b2 = 0; } if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] < 64) { /* * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, * then all our intermediate calculations can be done using exact * 64-bit arithmetic with no need for expensive multiprecision |
︙ | ︙ | |||
4854 4855 4856 4857 4858 4859 4860 | * too large to convert. * *---------------------------------------------------------------------- */ double TclBignumToDouble( | | | 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 | * too large to convert. * *---------------------------------------------------------------------- */ double TclBignumToDouble( const void *big) /* Integer to convert. */ { mp_int b; int bits, shift, i, lsb; double r; mp_err err; const mp_int *a = (const mp_int *)big; |
︙ | ︙ | |||
4975 4976 4977 4978 4979 4980 4981 | * Returns the floating point number. * *---------------------------------------------------------------------- */ double TclCeil( | | | 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 | * Returns the floating point number. * *---------------------------------------------------------------------- */ double TclCeil( const void *big) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_err err; const mp_int *a = (const mp_int *)big; err = mp_init(&b); |
︙ | ︙ | |||
5041 5042 5043 5044 5045 5046 5047 | * Returns the floating point value. * *---------------------------------------------------------------------- */ double TclFloor( | | | 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 | * Returns the floating point value. * *---------------------------------------------------------------------- */ double TclFloor( const void *big) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_err err; const mp_int *a = (const mp_int *)big; err = mp_init(&b); |
︙ | ︙ |
Changes to generic/tclStringObj.c.
1 2 3 | /* * tclStringObj.c -- * | | | | | | | | | 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 | /* * tclStringObj.c -- * * This file contains functions that implement string operations on Tcl * objects. Some string operations work with UTF-8 encoding forms. * Functions that require knowledge of the width of each character, * such as indexing, operate on fixed width encoding forms such as UTF-32. * * Conceptually, a string is a sequence of Unicode code points. Internally * it may be stored in an encoding form such as a modified version of * UTF-8 or UTF-32. * * The String object is optimized for the case where each UTF char * in a string is only one byte. In this case, we store the value of * numChars, but we don't store the fixed form encoding (unless * Tcl_GetUnicode is explicitly called). * * The String object type stores one or both formats. The default * behavior is to store UTF-8. Once UTF-16/UTF32 is calculated, it is * stored in the internal rep for future access (without an additional * O(n) cost). * * To allow many appends to be done to an object without constantly * reallocating space, we allocate double the space and use the * internal representation to keep track of how much space is used vs. * allocated. * * Copyright © 1995-1997 Sun Microsystems, Inc. |
︙ | ︙ | |||
120 121 122 123 124 125 126 | #ifndef TCL_MIN_UNICHAR_GROWTH #define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar) #endif static void GrowStringBuffer( Tcl_Obj *objPtr, | | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | #ifndef TCL_MIN_UNICHAR_GROWTH #define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar) #endif static void GrowStringBuffer( Tcl_Obj *objPtr, Tcl_Size needed, /* Not including terminating nul */ int flag) /* If 0, try to overallocate */ { /* * Preconditions: * TclHasInternalRep(objPtr, &tclStringType) * needed > stringPtr->allocated * flag || objPtr->bytes != NULL */ |
︙ | ︙ | |||
714 715 716 717 718 719 720 | * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_GetRange( Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ | | | | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 | * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_GetRange( Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ Tcl_Size first, /* First index of the range. */ Tcl_Size last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; Tcl_Size length = 0; if (first < 0) { first = 0; |
︙ | ︙ | |||
2755 2756 2757 2758 2759 2760 2761 | q = bytes + 4; while ((bytes < end) && (bytes < q) && ((*bytes & 0xC0) == 0x80)) { bytes++; } Tcl_ListObjAppendElement(NULL, list, | | | 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 | q = bytes + 4; while ((bytes < end) && (bytes < q) && ((*bytes & 0xC0) == 0x80)) { bytes++; } Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(bytes , (end - bytes))); break; } case 'p': if (sizeof(size_t) == sizeof(Tcl_WideInt)) { size = 2; } |
︙ | ︙ | |||
2800 2801 2802 2803 2804 2805 2806 | case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': if (size > 0) { | | | | | | 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 | case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': if (size > 0) { Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( (double)va_arg(argList, long double))); } else { Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( va_arg(argList, double))); } seekingConversion = 0; break; case '*': lastNum = va_arg(argList, int); Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum)); p++; |
︙ | ︙ | |||
3035 3036 3037 3038 3039 3040 3041 | } /* maxCount includes space for null */ if (count > (maxCount-1)) { if (interp) { TclPrintfResult(interp, "max size for a Tcl value (%" TCL_SIZE_MODIFIER | | < | 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 | } /* maxCount includes space for null */ if (count > (maxCount-1)) { if (interp) { TclPrintfResult(interp, "max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; } if (binary) { /* Efficiently produce a pure byte array result */ |
︙ | ︙ | |||
3264 3265 3266 3267 3268 3269 3270 | } length += numChars; } } } while (--oc); } else { /* Result will be concat of string reps. Pre-size it. */ | | < | 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 | } length += numChars; } } } while (--oc); } else { /* Result will be concat of string reps. Pre-size it. */ ov = objv; oc = objc; do { Tcl_Obj *pendingPtr = NULL; /* * Loop until a possibly non-empty value is reached. * Keep string rep generation pending when possible. */ |
︙ | ︙ | |||
3349 3350 3351 3352 3353 3354 3355 | if (last <= first /*|| length == 0 */) { /* Only one non-empty value or zero length; return first */ /* NOTE: (length == 0) implies (last <= first) */ return objv[first]; } | < | | < | 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 | if (last <= first /*|| length == 0 */) { /* Only one non-empty value or zero length; return first */ /* NOTE: (length == 0) implies (last <= first) */ return objv[first]; } objv += first; objc = (last - first + 1); inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv); if (binary) { /* Efficiently produce a pure byte array result */ unsigned char *dst; /* * Broken interface! Byte array value routines offer no way to handle * failure to allocate enough space. Following stanza may panic. */ if (inPlace) { Tcl_Size start = 0; objResultPtr = *objv++; objc--; (void)Tcl_GetBytesFromObj(NULL, objResultPtr, &start); dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; } else { objResultPtr = Tcl_NewByteArrayObj(NULL, length); dst = Tcl_SetByteArrayLength(objResultPtr, length); } while (objc--) { |
︙ | ︙ | |||
3396 3397 3398 3399 3400 3401 3402 | } else if ((allowUniChar && requestUniChar) || forceUniChar) { /* Efficiently produce a pure Tcl_UniChar array result */ Tcl_UniChar *dst; if (inPlace) { Tcl_Size start; | | < | 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 | } else if ((allowUniChar && requestUniChar) || forceUniChar) { /* Efficiently produce a pure Tcl_UniChar array result */ Tcl_UniChar *dst; if (inPlace) { Tcl_Size start; objResultPtr = *objv++; objc--; /* Ugly interface! Force resize of the unicode array. */ (void)Tcl_GetUnicodeFromObj(objResultPtr, &start); Tcl_InvalidateStringRep(objResultPtr); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { TclPrintfResult(interp, |
︙ | ︙ | |||
3448 3449 3450 3451 3452 3453 3454 | } else { /* Efficiently concatenate string reps */ char *dst; if (inPlace) { Tcl_Size start; | | < | 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 | } else { /* Efficiently concatenate string reps */ char *dst; if (inPlace) { Tcl_Size start; objResultPtr = *objv++; objc--; (void)TclGetStringFromObj(objResultPtr, &start); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { TclPrintfResult(interp, "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", |
︙ | ︙ | |||
3523 3524 3525 3526 3527 3528 3529 | * be changed. * *--------------------------------------------------------------------------- */ static int UniCharNcasememcmp( | | | | | | 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 | * be changed. * *--------------------------------------------------------------------------- */ static int UniCharNcasememcmp( const void *ucsPtr, /* Unicode string to compare to uct. */ const void *uctPtr, /* Unicode string ucs is compared to. */ size_t numChars) /* Number of Unichars to compare. */ { const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); Tcl_UniChar lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { return (lcs - lct); } } } return 0; } static int UtfNmemcmp( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ size_t numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; const char *cs = (const char *)csPtr; const char *ct = (const char *)ctPtr; /* * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the |
︙ | ︙ | |||
3578 3579 3580 3581 3582 3583 3584 | return 0; } static int UtfNcasememcmp( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ | | | 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 | return 0; } static int UtfNcasememcmp( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ size_t numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; const char *cs = (const char *)csPtr; const char *ct = (const char *)ctPtr; while (numChars-- > 0) { /* |
︙ | ︙ | |||
3605 3606 3607 3608 3609 3610 3611 | } } return 0; } static int UniCharNmemcmp( | | | | | 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 | } } return 0; } static int UniCharNmemcmp( const void *ucsPtr, /* Unicode string to compare to uct. */ const void *uctPtr, /* Unicode string ucs is compared to. */ size_t numChars) /* Number of unichars to compare. */ { const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; #if defined(WORDS_BIGENDIAN) /* * We are definitely on a big-endian machine; memcmp() is safe */ |
︙ | ︙ | |||
3639 3640 3641 3642 3643 3644 3645 | int TclStringCmp( Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, int checkEq, /* comparison is only for equality */ int nocase, /* comparison is not case sensitive */ Tcl_Size reqlength) /* requested length in characters; | | | 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 | int TclStringCmp( Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, int checkEq, /* comparison is only for equality */ int nocase, /* comparison is not case sensitive */ Tcl_Size reqlength) /* requested length in characters; * TCL_INDEX_NONE to compare whole strings */ { const char *s1, *s2; int empty, match; Tcl_Size length, s1len = 0, s2len = 0; memCmpFn_t memCmpFn; if ((reqlength == 0) || (value1Ptr == value2Ptr)) { |
︙ | ︙ | |||
3685 3686 3687 3688 3689 3690 3691 | } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); if ((s1len == value1Ptr->length) && (value1Ptr->bytes != NULL) && (s2len == value2Ptr->length) && (value2Ptr->bytes != NULL)) { | | | > | 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 | } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); if ((s1len == value1Ptr->length) && (value1Ptr->bytes != NULL) && (s2len == value2Ptr->length) && (value2Ptr->bytes != NULL)) { /* each byte represents one character so s1l3n, s2l3n, and * reqlength are in both bytes and characters */ s1 = value1Ptr->bytes; s2 = value2Ptr->bytes; memCmpFn = memcmp; } else { s1 = (char *) Tcl_GetUnicode(value1Ptr); s2 = (char *) Tcl_GetUnicode(value2Ptr); if ( |
︙ | ︙ |
Changes to generic/tclStubCall.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclStubCall.c -- * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifndef _WIN32 # include <dlfcn.h> #else | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclStubCall.c -- * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifndef _WIN32 # include <dlfcn.h> #else # define dlopen(a,b) (void *)LoadLibraryW(JOIN(L,a)) # define dlsym(a,b) (void *)GetProcAddress((HMODULE)(a),b) # define dlerror() "" #endif MODULE_SCOPE void *tclStubsHandle; /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
48 49 50 51 52 53 54 | "_Tcl_StaticLibrary", /* "arg" == (void *)6 */ "_Tcl_SetExitProc", /* "arg" == (void *)7 */ "_Tcl_GetMemoryInfo", /* "arg" == (void *)8 */ "_Tcl_SetPreInitScript" /* "arg" == (void *)9 */ }; MODULE_SCOPE const void *nullVersionProc(void) { | | | < | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | "_Tcl_StaticLibrary", /* "arg" == (void *)6 */ "_Tcl_SetExitProc", /* "arg" == (void *)7 */ "_Tcl_GetMemoryInfo", /* "arg" == (void *)8 */ "_Tcl_SetPreInitScript" /* "arg" == (void *)9 */ }; MODULE_SCOPE const void *nullVersionProc(void) { return NULL; } static const char CANNOTCALL[] = "Cannot call %s from stubbed extension\n"; static const char CANNOTFIND[] = "Cannot find %s: %s\n"; MODULE_SCOPE void * TclStubCall(void *arg) { static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}; size_t index = PTR2UINT(arg); if (index >= sizeof(PROCNAME)/sizeof(PROCNAME[0])) { /* Any other value means Tcl_SetPanicProc() with non-null panicProc */ index = 0; |
︙ | ︙ |
Changes to generic/tclStubInit.c.
︙ | ︙ | |||
92 93 94 95 96 97 98 | # define TclDictObjSize 0 # define TclSplitList 0 # define TclSplitPath 0 # define TclFSSplitPath 0 # define TclParseArgsObjv 0 # define TclGetAliasObj 0 #else /* !defined(TCL_NO_DEPRECATED) */ | < | < < | < < < < | < | < < < | < | < < < < | < | < < < | < < < < | < < < < < | | < < | < < < < | | < | < < | 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 | # define TclDictObjSize 0 # define TclSplitList 0 # define TclSplitPath 0 # define TclFSSplitPath 0 # define TclParseArgsObjv 0 # define TclGetAliasObj 0 #else /* !defined(TCL_NO_DEPRECATED) */ int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, void *objcPtr, Tcl_Obj ***objvPtr) { Tcl_Size n = TCL_INDEX_NONE; int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); if (objcPtr) { if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL); } return TCL_ERROR; } *(int *)objcPtr = (int)n; } return result; } int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, void *lengthPtr) { Tcl_Size n = TCL_INDEX_NONE; int result = Tcl_ListObjLength(interp, listPtr, &n); if (lengthPtr) { if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL); } return TCL_ERROR; } *(int *)lengthPtr = (int)n; } return result; } int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, void *sizePtr) { Tcl_Size n = TCL_INDEX_NONE; int result = Tcl_DictObjSize(interp, dictPtr, &n); if (sizePtr) { if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "Dict too large to be processed", (void *)NULL); } return TCL_ERROR; } *(int *)sizePtr = (int)n; } return result; } int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr, const char ***argvPtr) { Tcl_Size n = TCL_INDEX_NONE; int result = Tcl_SplitList(interp, listStr, &n, argvPtr); if (argcPtr) { if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL); } Tcl_Free((void *)*argvPtr); return TCL_ERROR; } *(int *)argcPtr = (int)n; } return result; } void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr) { Tcl_Size n = TCL_INDEX_NONE; Tcl_SplitPath(path, &n, argvPtr); if (argcPtr) { if ((sizeof(int) != sizeof(Tcl_Size)) && (n > INT_MAX)) { n = TCL_INDEX_NONE; /* No other way to return an error-situation */ Tcl_Free((void *)*argvPtr); *argvPtr = NULL; } *(int *)argcPtr = (int)n; } } Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr) { Tcl_Size n = TCL_INDEX_NONE; Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n); if (lenPtr) { if ((sizeof(int) != sizeof(Tcl_Size)) && result && (n > INT_MAX)) { Tcl_DecrRefCount(result); return NULL; } *(int *)lenPtr = (int)n; } return result; } int TclParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) { Tcl_Size n = (*(int *)objcPtr < 0) ? TCL_INDEX_NONE: (Tcl_Size)*(int *)objcPtr ; int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv); *(int *)objcPtr = (int)n; return result; } int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) { Tcl_Size n = TCL_INDEX_NONE; int result = Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, &n, objv); if (objcPtr) { if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "List too large to be processed", NULL); } |
︙ | ︙ | |||
340 341 342 343 344 345 346 | /* dummy implementation, no need to do anything */ } # define TclWinAddProcess (void (*) (void *, Tcl_Size)) doNothing # define TclWinFlushDirtyChannels doNothing #define TclWinNoBackslash winNoBackslash static char * | | < < | | < < | < < | < < < < | < < | < < < | 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 | /* dummy implementation, no need to do anything */ } # define TclWinAddProcess (void (*) (void *, Tcl_Size)) doNothing # define TclWinFlushDirtyChannels doNothing #define TclWinNoBackslash winNoBackslash static char * TclWinNoBackslash(char *path) { char *p; for (p = path; *p != '\0'; p++) { if (*p == '\\') { *p = '/'; } } return path; } void *TclWinGetTclInstance(void) { void *hInstance = NULL; GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, (const wchar_t *)&TclWinNoBackslash, &hInstance); return hInstance; } Tcl_Size TclpGetPid(Tcl_Pid pid) { return (Tcl_Size)PTR2INT(pid); } #if defined(TCL_WIDE_INT_IS_LONG) /* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore * we have to make sure that all stub entries on Cygwin64 follow the Win64 * signature. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ #define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)Tcl_GetIntFromObj static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ long longValue; int result = Tcl_ExprLong(interp, expr, &longValue); if (result == TCL_OK) { if ((longValue >= (long)(INT_MIN)) && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); result = TCL_ERROR; } } return result; } #define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))(void *)exprInt static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ long longValue; int result = Tcl_ExprLongObj(interp, expr, &longValue); if (result == TCL_OK) { if ((longValue >= (long)(INT_MIN)) && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { |
︙ | ︙ | |||
451 452 453 454 455 456 457 | */ #pragma GCC diagnostic ignored "-Wdeprecated-declarations" #endif #ifdef TCL_WITH_EXTERNAL_TOMMATH /* If Tcl is linked with an external libtommath 1.2.x, then mp_expt_n doesn't * exist (since that was introduced in libtommath 1.3.0. Provide it here.) */ | | < < < < < | | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 | */ #pragma GCC diagnostic ignored "-Wdeprecated-declarations" #endif #ifdef TCL_WITH_EXTERNAL_TOMMATH /* If Tcl is linked with an external libtommath 1.2.x, then mp_expt_n doesn't * exist (since that was introduced in libtommath 1.3.0. Provide it here.) */ mp_err MP_WUR TclBN_mp_expt_n(const mp_int *a, int b, mp_int *c) { if ((unsigned)b > MP_MIN(MP_DIGIT_MAX, INT_MAX)) { return MP_VAL; } return mp_expt_u32(a, (uint32_t)b, c);; } #endif /* TCL_WITH_EXTERNAL_TOMMATH */ /* !BEGIN!: Do not edit below this line. */ static const TclIntStubs tclIntStubs = { |
︙ | ︙ |
Changes to generic/tclStubLib.c.
︙ | ︙ | |||
88 89 90 91 92 93 94 | count += !ISDIGIT(*p++); } if (count == 1) { const char *q = actualVersion; p = version; while (*p && (*p == *q)) { | | < | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | count += !ISDIGIT(*p++); } if (count == 1) { const char *q = actualVersion; p = version; while (*p && (*p == *q)) { p++; q++; } if (*p || ISDIGIT(*q)) { /* Construct error message */ stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 1, NULL); return NULL; } } else { |
︙ | ︙ |
Changes to generic/tclThread.c.
︙ | ︙ | |||
19 20 21 22 23 24 25 | * used for these objects so they can be finalized. * * These statics are guarded by the mutex in the caller of * TclRememberThreadData, e.g., TclpThreadDataKeyInit */ typedef struct { | | | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | * used for these objects so they can be finalized. * * These statics are guarded by the mutex in the caller of * TclRememberThreadData, e.g., TclpThreadDataKeyInit */ typedef struct { int num; /* Number of objects remembered */ int max; /* Max size of the array */ void **list; /* List of pointers */ } SyncObjRecord; static SyncObjRecord keyRecord = {0, 0, NULL}; static SyncObjRecord mutexRecord = {0, 0, NULL}; static SyncObjRecord condRecord = {0, 0, NULL}; /* |
︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
︙ | ︙ | |||
88 89 90 91 92 93 94 | size_t numFree; /* Number of blocks available */ /* All fields below for accounting only */ size_t numRemoves; /* Number of removes from bucket */ size_t numInserts; /* Number of inserts into bucket */ size_t numLocks; /* Number of locks acquired */ | | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | size_t numFree; /* Number of blocks available */ /* All fields below for accounting only */ size_t numRemoves; /* Number of removes from bucket */ size_t numInserts; /* Number of inserts into bucket */ size_t numLocks; /* Number of locks acquired */ size_t totalAssigned; /* Total space assigned to bucket */ } Bucket; /* * The following structure defines a cache of buckets and objs, of which there * will be (at most) one per thread. Any changes need to be reflected in the * struct AllocCache defined in tclInt.h, possibly also in the initialisation * code in Tcl_CreateInterp(). |
︙ | ︙ | |||
116 117 118 119 120 121 122 | * The following array specifies various per-bucket limits and locks. The * values are statically initialized to avoid calculating them repeatedly. */ static struct { size_t blockSize; /* Bucket blocksize. */ size_t maxBlocks; /* Max blocks before move to share. */ | | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 | * The following array specifies various per-bucket limits and locks. The * values are statically initialized to avoid calculating them repeatedly. */ static struct { size_t blockSize; /* Bucket blocksize. */ size_t maxBlocks; /* Max blocks before move to share. */ size_t numMove; /* Num blocks to move to share. */ Tcl_Mutex *lockPtr; /* Share bucket lock. */ } bucketInfo[NBUCKETS]; /* * Static functions defined in this file. */ |
︙ | ︙ | |||
210 211 212 213 214 215 216 | cachePtr = (Cache*)TclpGetAllocCache(); if (cachePtr == NULL) { cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache)); if (cachePtr == NULL) { Tcl_Panic("alloc: could not allocate new cache"); } | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | cachePtr = (Cache*)TclpGetAllocCache(); if (cachePtr == NULL) { cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache)); if (cachePtr == NULL) { Tcl_Panic("alloc: could not allocate new cache"); } memset(cachePtr, 0, sizeof(Cache)); Tcl_MutexLock(listLockPtr); cachePtr->nextPtr = firstCachePtr; firstCachePtr = cachePtr; Tcl_MutexUnlock(listLockPtr); cachePtr->owner = Tcl_GetCurrentThread(); TclpSetAllocCache(cachePtr); } |
︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 | /* *---------------------------------------------------------------------- * * TclInitThreadAlloc -- * * Initializes the allocator cache-maintenance structures. | | | 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 | /* *---------------------------------------------------------------------- * * TclInitThreadAlloc -- * * Initializes the allocator cache-maintenance structures. * It is done early and protected during the Tcl_InitSubsystems(). * * Results: * None. * * Side effects: * None. * |
︙ | ︙ |
Changes to generic/tclThreadStorage.c.
︙ | ︙ | |||
44 45 46 47 48 49 50 | } tsdGlobal = { NULL, 0, NULL }; /* * The type of the data held per thread in a system TSD. */ typedef struct { | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | } tsdGlobal = { NULL, 0, NULL }; /* * The type of the data held per thread in a system TSD. */ typedef struct { void **tablePtr; /* The table of Tcl TSDs. */ sig_atomic_t allocated; /* The size of the table in the current * thread. */ } TSDTable; /* * The actual type of Tcl_ThreadDataKey. */ |
︙ | ︙ |
Changes to generic/tclTimer.c.
︙ | ︙ | |||
17 18 19 20 21 22 23 | * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained * together in a list sorted by time (earliest event first). */ typedef struct TimerHandler { Tcl_Time time; /* When timer is to fire. */ Tcl_TimerProc *proc; /* Function to call. */ | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained * together in a list sorted by time (earliest event first). */ typedef struct TimerHandler { Tcl_Time time; /* When timer is to fire. */ Tcl_TimerProc *proc; /* Function to call. */ void *clientData; /* Argument to pass to proc. */ Tcl_TimerToken token; /* Identifies handler so it can be deleted. */ struct TimerHandler *nextPtr; /* Next event in queue, or NULL for end of * queue. */ } TimerHandler; /* |
︙ | ︙ | |||
69 70 71 72 73 74 75 | * There is one of the following structures for each of the handlers declared * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are * linked together into a list. */ typedef struct IdleHandler { Tcl_IdleProc *proc; /* Function to call. */ | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | * There is one of the following structures for each of the handlers declared * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are * linked together into a list. */ typedef struct IdleHandler { Tcl_IdleProc *proc; /* Function to call. */ void *clientData; /* Value to pass to proc. */ int generation; /* Used to distinguish older handlers from * recently-created ones. */ struct IdleHandler *nextPtr;/* Next in list of active handlers. */ } IdleHandler; /* * The timer and idle queues are per-thread because they are associated with |
︙ | ︙ | |||
247 248 249 250 251 252 253 | */ Tcl_TimerToken Tcl_CreateTimerHandler( int milliseconds, /* How many milliseconds to wait before * invoking proc. */ Tcl_TimerProc *proc, /* Function to invoke. */ | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | */ Tcl_TimerToken Tcl_CreateTimerHandler( int milliseconds, /* How many milliseconds to wait before * invoking proc. */ Tcl_TimerProc *proc, /* Function to invoke. */ void *clientData) /* Arbitrary data to pass to proc. */ { Tcl_Time time; /* * Compute when the event should fire. */ |
︙ | ︙ | |||
615 616 617 618 619 620 621 | * *-------------------------------------------------------------- */ void Tcl_DoWhenIdle( Tcl_IdleProc *proc, /* Function to invoke. */ | | | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 | * *-------------------------------------------------------------- */ void Tcl_DoWhenIdle( Tcl_IdleProc *proc, /* Function to invoke. */ void *clientData) /* Arbitrary value to pass to proc. */ { IdleHandler *idlePtr; Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); idlePtr = (IdleHandler *)Tcl_Alloc(sizeof(IdleHandler)); idlePtr->proc = proc; |
︙ | ︙ | |||
659 660 661 662 663 664 665 | * *---------------------------------------------------------------------- */ void Tcl_CancelIdleCall( Tcl_IdleProc *proc, /* Function that was previously registered. */ | | | 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 | * *---------------------------------------------------------------------- */ void Tcl_CancelIdleCall( Tcl_IdleProc *proc, /* Function that was previously registered. */ void *clientData) /* Arbitrary value to pass to proc. */ { IdleHandler *idlePtr, *prevPtr; IdleHandler *nextPtr; ThreadSpecificData *tsdPtr = InitTimer(); for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL; prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) { |
︙ | ︙ | |||
819 820 821 822 823 824 825 | if (TclGetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK) { const char *arg = TclGetString(objv[1]); TclPrintfResult(interp, | | | | | | 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 | if (TclGetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK) { const char *arg = TclGetString(objv[1]); TclPrintfResult(interp, "bad argument \"%s\": must be" " cancel, idle, info, or an integer", arg); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", arg, (void *)NULL); return TCL_ERROR; } } /* * At this point, either index = -1 and ms contains the number of ms * to wait, or else index is the index of a subcommand. |
︙ | ︙ | |||
948 949 950 951 952 953 954 | for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { if (assocPtr->interp == interp) { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf( "after#%d", afterPtr->id)); } } | | | | > | | | 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 | for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { if (assocPtr->interp == interp) { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf( "after#%d", afterPtr->id)); } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?id?"); return TCL_ERROR; } afterPtr = GetAfterEvent(assocPtr, objv[2]); if (afterPtr == NULL) { const char *eventStr = TclGetString(objv[2]); TclPrintfResult(interp, "event \"%s\" doesn't exist", eventStr); Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, (void *)NULL); return TCL_ERROR; } else { Tcl_Obj *resultListPtr; TclNewObj(resultListPtr); Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( (afterPtr->token == NULL) ? "idle" : "timer", -1)); Tcl_SetObjResult(interp, resultListPtr); } break; default: Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); } return TCL_OK; } |
︙ | ︙ | |||
1038 1039 1040 1041 1042 1043 1044 | } if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } | | | | | | | | | | 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 | } if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { diff = 1; } if (diff > 0) { Tcl_Sleep((int) diff); if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { break; } } else { break; } } else { diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } if (diff > 0) { Tcl_Sleep((int) diff); |
︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 | * bgerror fails then information about the error is output on stderr. * *---------------------------------------------------------------------- */ static void AfterProc( | | | 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 | * bgerror fails then information about the error is output on stderr. * *---------------------------------------------------------------------- */ static void AfterProc( void *clientData) /* Describes command to execute. */ { AfterInfo *afterPtr = (AfterInfo *)clientData; AfterAssocData *assocPtr = afterPtr->assocPtr; AfterInfo *prevPtr; int result; Tcl_Interp *interp; |
︙ | ︙ | |||
1209 1210 1211 1212 1213 1214 1215 | * The memory associated with afterPtr is released. * *---------------------------------------------------------------------- */ static void FreeAfterPtr( | | | 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 | * The memory associated with afterPtr is released. * *---------------------------------------------------------------------- */ static void FreeAfterPtr( AfterInfo *afterPtr) /* Command to be deleted. */ { AfterInfo *prevPtr; AfterAssocData *assocPtr = afterPtr->assocPtr; if (assocPtr->firstAfterPtr == afterPtr) { assocPtr->firstAfterPtr = afterPtr->nextPtr; } else { |
︙ | ︙ | |||
1246 1247 1248 1249 1250 1251 1252 | * After commands are removed. * *---------------------------------------------------------------------- */ static void AfterCleanupProc( | | | 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 | * After commands are removed. * *---------------------------------------------------------------------- */ static void AfterCleanupProc( void *clientData, /* Points to AfterAssocData for the * interpreter. */ TCL_UNUSED(Tcl_Interp *)) { AfterAssocData *assocPtr = (AfterAssocData *)clientData; AfterInfo *afterPtr; while (assocPtr->firstAfterPtr != NULL) { |
︙ | ︙ |
Changes to generic/tclTrace.c.
︙ | ︙ | |||
18 19 20 21 22 23 24 | * Structures used to hold information about variable traces: */ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ Tcl_Size length; /* Number of non-NUL chars. in command. */ | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | * Structures used to hold information about variable traces: */ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ Tcl_Size length; /* Number of non-NUL chars. in command. */ char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 1 * byte. */ } TraceVarInfo; typedef struct { |
︙ | ︙ | |||
40 41 42 43 44 45 46 | typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ Tcl_Size length; /* Number of non-NUL chars. in command. */ Tcl_Trace stepTrace; /* Used for execution traces, when tracing * inside the given command */ | | | | 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 | typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ Tcl_Size length; /* Number of non-NUL chars. in command. */ Tcl_Trace stepTrace; /* Used for execution traces, when tracing * inside the given command */ Tcl_Size startLevel; /* Used for bookkeeping with step execution * traces, store the level at which the step * trace was invoked */ char *startCmd; /* Used for bookkeeping with step execution * traces, store the command name which * invoked step trace */ int curFlags; /* Trace flags for the current command */ int curCode; /* Return code for the current command */ size_t refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 1 * byte. */ } TraceCommandInfo; /* |
︙ | ︙ | |||
142 143 144 145 146 147 148 | /* * The following structure holds the client data for string-based * trace procs */ typedef struct { | | | | | | | 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 | /* * The following structure holds the client data for string-based * trace procs */ typedef struct { void *clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; /* * Convenience macros for iterating over the list of traces. Note that each of * these *must* be treated as a command, and *must* have a block following it. */ #define FOREACH_VAR_TRACE(interp, name, clientData) \ (clientData) = NULL; \ while (((clientData) = Tcl_VarTraceInfo2((interp), (name), NULL, \ 0, TraceVarProc, (clientData))) != NULL) #define FOREACH_COMMAND_TRACE(interp, name, clientData) \ (clientData) = NULL; \ while (((clientData) = Tcl_CommandTraceInfo((interp), (name), 0, \ TraceCommandProc, (clientData))) != NULL) /* *---------------------------------------------------------------------- * * Tcl_TraceObjCmd -- * |
︙ | ︙ | |||
275 276 277 278 279 280 281 | * *---------------------------------------------------------------------- */ static int TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ | | < | | 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 | * *---------------------------------------------------------------------- */ static int TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ enum traceOptionsEnum optionIndex, /* Add, info or remove */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; Tcl_Size length; static const char *const opStrings[] = { "enter", "leave", "enterstep", "leavestep", NULL }; |
︙ | ︙ | |||
380 381 382 383 384 385 386 | void *clientData; /* * First ensure the name given is valid. */ name = TclGetString(objv[3]); | | | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 | void *clientData; /* * First ensure the name given is valid. */ name = TclGetString(objv[3]); if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } FOREACH_COMMAND_TRACE(interp, name, clientData) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; /* |
︙ | ︙ | |||
523 524 525 526 527 528 529 | * *---------------------------------------------------------------------- */ static int TraceCommandObjCmd( Tcl_Interp *interp, /* Current interpreter. */ | | < | | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 | * *---------------------------------------------------------------------- */ static int TraceCommandObjCmd( Tcl_Interp *interp, /* Current interpreter. */ enum traceOptionsEnum optionIndex, /* Add, info or remove */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; Tcl_Size length; static const char *const opStrings[] = { "delete", "rename", NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME } index; |
︙ | ︙ | |||
614 615 616 617 618 619 620 | void *clientData; /* * First ensure the name given is valid. */ name = TclGetString(objv[3]); | | | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 | void *clientData; /* * First ensure the name given is valid. */ name = TclGetString(objv[3]); if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } FOREACH_COMMAND_TRACE(interp, name, clientData) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) |
︙ | ︙ | |||
718 719 720 721 722 723 724 | * *---------------------------------------------------------------------- */ static int TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ | | < | | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 | * *---------------------------------------------------------------------- */ static int TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ enum traceOptionsEnum optionIndex, /* Add, info or remove */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; Tcl_Size length; void *clientData; static const char *const opStrings[] = { "array", "read", "unset", "write", NULL |
︙ | ︙ | |||
980 981 982 983 984 985 986 | * traced. */ const char *cmdName, /* Name of command. */ int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function to call when specified ops are * invoked upon cmdName. */ | | | 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 | * traced. */ const char *cmdName, /* Name of command. */ int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function to call when specified ops are * invoked upon cmdName. */ void *clientData) /* Arbitrary argument to pass to proc. */ { Command *cmdPtr; CommandTrace *tracePtr; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { |
︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 | Tcl_UntraceCommand( Tcl_Interp *interp, /* Interpreter containing command. */ const char *cmdName, /* Name of command. */ int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ | | | 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 | Tcl_UntraceCommand( Tcl_Interp *interp, /* Interpreter containing command. */ const char *cmdName, /* Name of command. */ int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ void *clientData) /* Arbitrary argument to pass to proc. */ { CommandTrace *tracePtr; CommandTrace *prevPtr; Command *cmdPtr; Interp *iPtr = (Interp *)interp; ActiveCommandTrace *activePtr; int hasExecTraces = 0; |
︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 | /* * None of the remaining traces on this command are execution traces. * We therefore remove this flag: */ cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; | | | 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 | /* * None of the remaining traces on this command are execution traces. * We therefore remove this flag: */ cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; /* * Bug 3484621: up the interp's epoch if this is a BC'ed command */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } } |
︙ | ︙ | |||
1148 1149 1150 1151 1152 1153 1154 | * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ static void TraceCommandProc( | | | 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 | * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ static void TraceCommandProc( void *clientData, /* Information about the command trace. */ Tcl_Interp *interp, /* Interpreter containing command. */ const char *oldName, /* Name of command being changed. */ const char *newName, /* New name of command. Empty string or NULL * means command is being deleted (renamed to * ""). */ int flags) /* OR-ed bits giving operation and other * information. */ |
︙ | ︙ | |||
1293 1294 1295 1296 1297 1298 1299 | Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ TCL_UNUSED(Tcl_Size) /*numChars*/, Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ | | | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 | Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ TCL_UNUSED(Tcl_Size) /*numChars*/, Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; CommandTrace *tracePtr, *lastTracePtr; ActiveCommandTrace active; Tcl_Size curLevel; int traceCode = TCL_OK; |
︙ | ︙ | |||
1399 1400 1401 1402 1403 1404 1405 | const char *command, /* Pointer to beginning of the current command * string. */ Tcl_Size numChars, /* The number of characters in 'command' which * are part of the command string. */ Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ | | | 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 | const char *command, /* Pointer to beginning of the current command * string. */ Tcl_Size numChars, /* The number of characters in 'command' which * are part of the command string. */ Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; Trace *tracePtr, *lastTracePtr; ActiveInterpTrace active; Tcl_Size curLevel; int traceCode = TCL_OK; |
︙ | ︙ | |||
1537 1538 1539 1540 1541 1542 1543 | * *---------------------------------------------------------------------- */ static int CallTraceFunction( Tcl_Interp *interp, /* The current interpreter. */ | | | 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 | * *---------------------------------------------------------------------- */ static int CallTraceFunction( Tcl_Interp *interp, /* The current interpreter. */ Trace *tracePtr, /* Describes the trace function to call. */ Command *cmdPtr, /* Points to command's Command struct. */ const char *command, /* Points to the first character of the * command's source before substitutions. */ Tcl_Size numChars, /* The number of characters in the command's * source. */ Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ |
︙ | ︙ | |||
1832 1833 1834 1835 1836 1837 1838 | * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ static char * TraceVarProc( | | | 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 | * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ static char * TraceVarProc( void *clientData, /* Information about the variable trace. */ Tcl_Interp *interp, /* Interpreter containing variable. */ const char *name1, /* Name of variable or array. */ const char *name2, /* Name of element within array; NULL means * scalar variable is being referenced. */ int flags) /* OR-ed bits giving operation and other * information. */ { |
︙ | ︙ | |||
2015 2016 2017 2018 2019 2020 2021 | } Tcl_Free(info); } Tcl_Trace Tcl_CreateObjTrace( Tcl_Interp *interp, /* Tcl interpreter */ | | | | | | 2012 2013 2014 2015 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 2045 2046 2047 2048 | } Tcl_Free(info); } Tcl_Trace Tcl_CreateObjTrace( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ Tcl_CmdObjTraceProc *proc, /* Trace callback */ void *clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo)); info->proc = proc; info->delProc = delProc; info->clientData = clientData; return Tcl_CreateObjTrace2(interp, level, flags, (proc ? traceWrapperProc : NULL), info, traceWrapperDelProc); } Tcl_Trace Tcl_CreateObjTrace2( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ Tcl_CmdObjTraceProc2 *proc, /* Trace callback */ void *clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { Trace *tracePtr; Interp *iPtr = (Interp *) interp; /* |
︙ | ︙ | |||
2123 2124 2125 2126 2127 2128 2129 | * *---------------------------------------------------------------------- */ Tcl_Trace Tcl_CreateTrace( Tcl_Interp *interp, /* Interpreter in which to create trace. */ | | | | 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 | * *---------------------------------------------------------------------- */ Tcl_Trace Tcl_CreateTrace( Tcl_Interp *interp, /* Interpreter in which to create trace. */ Tcl_Size level, /* Only call proc for commands at nesting * level<=argument level (1=>top level). */ Tcl_CmdTraceProc *proc, /* Function to call before executing each * command. */ void *clientData) /* Arbitrary value word to pass to proc. */ { StringTraceData *data = (StringTraceData *)Tcl_Alloc(sizeof(StringTraceData)); data->clientData = clientData; data->proc = proc; return Tcl_CreateObjTrace2(interp, level, 0, StringTraceProc, data, StringTraceDeleteProc); |
︙ | ︙ | |||
2433 2434 2435 2436 2437 2438 2439 | * *---------------------------------------------------------------------- */ int TclObjCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ | | | 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 | * *---------------------------------------------------------------------- */ int TclObjCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ Var *arrayPtr, /* Pointer to array variable that contains the * variable, or NULL if the variable isn't an * element of an array. */ Var *varPtr, /* Variable whose traces are to be invoked. */ Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, /* Variable's two-part name. */ int flags, /* Flags passed to trace functions: indicates * what's happening to variable, plus maybe |
︙ | ︙ | |||
2467 2468 2469 2470 2471 2472 2473 | return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg); } int TclCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ | | | 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 | return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg); } int TclCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ Var *arrayPtr, /* Pointer to array variable that contains the * variable, or NULL if the variable isn't an * element of an array. */ Var *varPtr, /* Variable whose traces are to be invoked. */ const char *part1, const char *part2, /* Variable's two-part name. */ int flags, /* Flags passed to trace functions: indicates * what's happening to variable, plus maybe |
︙ | ︙ | |||
2546 2547 2548 2549 2550 2551 2552 | } } } /* Keep the original pointer for possible use in an error message */ element = part2; if (part2 == NULL) { | | | | | | | | | | 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 | } } } /* Keep the original pointer for possible use in an error message */ element = part2; if (part2 == NULL) { if (TclIsVarArrayElement(varPtr)) { Tcl_Obj *keyObj = VarHashGetKey(varPtr); part2 = Tcl_GetString(keyObj); } } else if ((flags & VAR_TRACED_UNSET) && !(flags & VAR_ARRAY_ELEMENT)) { /* On unset traces, part2 has already been set by the caller, and * the VAR_ARRAY_ELEMENT flag indicates whether the accessed * variable actually has a second part, or is a scalar */ element = NULL; } /* * Invoke traces on the array containing the variable, if relevant. */ result = NULL; |
︙ | ︙ | |||
2689 2690 2691 2692 2693 2694 2695 | TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, result); } iPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_DiscardInterpState(state); } else { Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); } | | | 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 | TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, result); } iPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_DiscardInterpState(state); } else { Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); } DisposeTraceResult(disposeFlags,result); } else if (state) { if (code == TCL_OK) { code = Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); } else { Tcl_DiscardInterpState(state); } } |
︙ | ︙ | |||
2774 2775 2776 2777 2778 2779 2780 | * trace applies to scalar variable or array * as-a-whole. */ int flags, /* OR-ed collection of bits describing current * trace, including any of TCL_TRACE_READS, * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function associated with trace. */ | | | 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 | * trace applies to scalar variable or array * as-a-whole. */ int flags, /* OR-ed collection of bits describing current * trace, including any of TCL_TRACE_READS, * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function associated with trace. */ void *clientData) /* Arbitrary argument to pass to proc. */ { VarTrace *tracePtr; VarTrace *prevPtr, *nextPtr; Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; int flagMask, allFlags = 0; |
︙ | ︙ | |||
2977 2978 2979 2980 2981 2982 2983 | * as-a-whole. */ int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function to call when specified ops are * invoked upon varName. */ | | | 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 | * as-a-whole. */ int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function to call when specified ops are * invoked upon varName. */ void *clientData) /* Arbitrary argument to pass to proc. */ { VarTrace *tracePtr; int result; tracePtr = (VarTrace *)Tcl_Alloc(sizeof(VarTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; |
︙ | ︙ |
Changes to generic/tclUtf.c.
︙ | ︙ | |||
128 129 130 131 132 133 134 | * * Given a pointer to a two-byte prefix of a well-formed UTF-8 byte * sequence (a lead byte followed by a trail byte) this routine * examines those two bytes to determine whether the sequence is * invalid in UTF-8. This might be because it is an overlong * encoding, or because it encodes something out of the proper range. * | | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | * * Given a pointer to a two-byte prefix of a well-formed UTF-8 byte * sequence (a lead byte followed by a trail byte) this routine * examines those two bytes to determine whether the sequence is * invalid in UTF-8. This might be because it is an overlong * encoding, or because it encodes something out of the proper range. * * Given a pointer to the bytes \xF8 or \xFC , this routine will * try to read beyond the end of the "bounds" table. Callers must * prevent this. * * Given a pointer to something else (an ASCII byte, a trail byte, * or another byte that can never begin a valid byte sequence such * as \xF5) this routine returns false. That makes the routine poorly * named, as it does not detect and report all invalid sequences. |
︙ | ︙ | |||
157 158 159 160 161 162 163 | 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */ 0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */ 0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */ }; static int Invalid( | | < | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */ 0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */ 0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */ }; static int Invalid( const char *src) /* Points to lead byte of a UTF-8 byte sequence */ { unsigned char byte = UCHAR(*src); int index; if ((byte & 0xC3) == 0xC0) { /* Only lead bytes 0xC0, 0xE0, 0xF0, 0xF4 need examination */ index = (byte - 0xC0) >> 1; |
︙ | ︙ | |||
306 307 308 309 310 311 312 | * None. * *--------------------------------------------------------------------------- */ char * Tcl_UniCharToUtfDString( | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | * None. * *--------------------------------------------------------------------------- */ char * Tcl_UniCharToUtfDString( const int *uniStr, /* Unicode string to convert to UTF-8. */ Tcl_Size uniLength, /* Length of Unicode string. Negative for nul * terminated string */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { const int *w, *wEnd; char *p, *string; |
︙ | ︙ | |||
437 438 439 440 441 442 443 | 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F, 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014, 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 }; Tcl_Size Tcl_UtfToUniChar( | | | | | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 | 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F, 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014, 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 }; Tcl_Size Tcl_UtfToUniChar( const char *src, /* The UTF-8 string. */ int *chPtr)/* Filled with the Unicode character represented by * the UTF-8 string. */ { int byte; /* * Unroll 1 to 4 byte UTF-8 sequences. */ |
︙ | ︙ | |||
497 498 499 500 501 502 503 | } /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ } else if (byte < 0xF5) { | < | | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 | } /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ } else if (byte < 0xF5) { if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) { /* * Four-byte-character lead byte followed by three trail bytes. */ *chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)); if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) { return 4; |
︙ | ︙ | |||
521 522 523 524 525 526 527 | *chPtr = byte; return 1; } Tcl_Size Tcl_UtfToChar16( | | | | < | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 | *chPtr = byte; return 1; } Tcl_Size Tcl_UtfToChar16( const char *src, /* The UTF-8 string. */ unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by * the UTF-8 string. This could be a surrogate too. */ { unsigned short byte; /* * Unroll 1 to 4 byte UTF-8 sequences. */ |
︙ | ︙ | |||
800 801 802 803 804 805 806 | * None. * *--------------------------------------------------------------------------- */ Tcl_Size Tcl_NumUtfChars( | | | | | 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 | * None. * *--------------------------------------------------------------------------- */ Tcl_Size Tcl_NumUtfChars( const char *src, /* The UTF-8 string to measure. */ Tcl_Size length) /* The length of the string in bytes, or * negative value for strlen(src). */ { Tcl_UniChar ch = 0; Tcl_Size i = 0; if (length < 0) { /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ while (*src != '\0') { |
︙ | ︙ | |||
852 853 854 855 856 857 858 | } } return i; } Tcl_Size TclNumUtfChars( | | | | | 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 | } } return i; } Tcl_Size TclNumUtfChars( const char *src, /* The UTF-8 string to measure. */ Tcl_Size length) /* The length of the string in bytes, or * negative for strlen(src). */ { unsigned short ch = 0; Tcl_Size i = 0; if (length < 0) { /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ while (*src != '\0') { |
︙ | ︙ | |||
1176 1177 1178 1179 1180 1181 1182 | * None. * *--------------------------------------------------------------------------- */ int Tcl_UniCharAtIndex( | | | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 | * None. * *--------------------------------------------------------------------------- */ int Tcl_UniCharAtIndex( const char *src, /* The UTF-8 string to dereference. */ Tcl_Size index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; int i = 0; if (index < 0) { return -1; } |
︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 | * None. * *--------------------------------------------------------------------------- */ const char * Tcl_UtfAtIndex( | | | | | | 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 | * None. * *--------------------------------------------------------------------------- */ const char * Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ Tcl_Size index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; while (index-- > 0) { src += TclUtfToUniChar(src, &ch); } return src; } const char * TclUtfAtIndex( const char *src, /* The UTF-8 string. */ Tcl_Size index) /* The position of the desired character. */ { unsigned short ch = 0; Tcl_Size len = 0; if (index > 0) { while (index--) { src += (len = Tcl_UtfToChar16(src, &ch)); |
︙ | ︙ | |||
1489 1490 1491 1492 1493 1494 1495 | *---------------------------------------------------------------------- */ int TclpUtfNcmp2( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ | | | 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 | *---------------------------------------------------------------------- */ int TclpUtfNcmp2( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ size_t numBytes) /* Number of *bytes* to compare. */ { const char *cs = (const char *)csPtr; const char *ct = (const char *)ctPtr; /* * We can't simply call 'memcmp(cs, ct, numBytes);' because we need to * check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes * fine in the strcmp manner. |
︙ | ︙ | |||
1522 1523 1524 1525 1526 1527 1528 | } /* *---------------------------------------------------------------------- * * Tcl_UtfNcmp -- * | | | | | | | | | | | | 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 | } /* *---------------------------------------------------------------------- * * Tcl_UtfNcmp -- * * Compare at most numChars chars (not bytes) of string cs to string ct. Both cs * and ct are assumed to be at least numChars chars long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclUtfNcmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ size_t numChars) /* Number of UTF-16 chars to compare. */ { unsigned short ch1 = 0, ch2 = 0; /* * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001 * (the byte 0x01.) */ while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. This should be called * only when both strings are of at least n UTF-16 chars long (no need for \0 * check) */ cs += Tcl_UtfToChar16(cs, &ch1); ct += Tcl_UtfToChar16(ct, &ch2); if (ch1 != ch2) { /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { return ch1; } } else if ((ch2 & 0xFC00) == 0xD800) { return -ch2; } return (ch1 - ch2); } } return 0; } int Tcl_UtfNcmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ size_t numChars) /* Number of chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; /* * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001 * (the byte 0x01.) |
︙ | ︙ | |||
1607 1608 1609 1610 1611 1612 1613 | } /* *---------------------------------------------------------------------- * * Tcl_UtfNcasecmp -- * | | | | | | | | | | | 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 | } /* *---------------------------------------------------------------------- * * Tcl_UtfNcasecmp -- * * Compare at most numChars chars (not bytes) of string cs to string ct case * insensitive. Both cs and ct are assumed to be at least numChars UTF * chars long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclUtfNcasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ size_t numChars) /* Number of UTF-16 chars to compare. */ { unsigned short ch1 = 0, ch2 = 0; while (numChars-- > 0) { /* * n must be interpreted as UTF-16 chars, not bytes. * This should be called only when both strings are of * at least n UTF-16 chars long (no need for \0 check) */ cs += Tcl_UtfToChar16(cs, &ch1); ct += Tcl_UtfToChar16(ct, &ch2); if (ch1 != ch2) { /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { return ch1; } } else if ((ch2 & 0xFC00) == 0xD800) { return -ch2; } ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return (ch1 - ch2); } } } return 0; } int Tcl_UtfNcasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ size_t numChars) /* Number of chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. * This should be called only when both strings are of |
︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_UniCharLen( | | | 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_UniCharLen( const int *uniStr) /* Unicode string to find length of. */ { Tcl_Size len = 0; while (*uniStr != '\0') { len++; uniStr++; } |
︙ | ︙ | |||
1940 1941 1942 1943 1944 1945 1946 | *---------------------------------------------------------------------- */ int TclUniCharNcmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ | | | 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 | *---------------------------------------------------------------------- */ int TclUniCharNcmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ size_t numChars) /* Number of chars to compare. */ { #if defined(WORDS_BIGENDIAN) /* * We are definitely on a big-endian machine; memcmp() is safe */ return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); |
︙ | ︙ | |||
1968 1969 1970 1971 1972 1973 1974 | } /* *---------------------------------------------------------------------- * * TclUniCharNcasecmp -- * | | | | | 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 | } /* *---------------------------------------------------------------------- * * TclUniCharNcasecmp -- * * Compare at most numChars chars (not bytes) of string ucs to string uct case * insensitive. Both ucs and uct are assumed to be at least numChars * chars long. * * Results: * Return <0 if ucs < uct, 0 if ucs == uct, or >0 if ucs > uct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclUniCharNcasecmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ size_t numChars) /* Number of chars to compare. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); Tcl_UniChar lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { |
︙ | ︙ |
Changes to generic/tclUtil.c.
︙ | ︙ | |||
120 121 122 123 124 125 126 | * for it. This is a caching internalrep, keeping the result of a parse * around. This type is only created from a pre-existing string, so an * updateStringProc will never be called and need not exist. The type * is unregistered, so has no need of a setFromAnyProc either. */ static const Tcl_ObjType endOffsetType = { | | | | | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | * for it. This is a caching internalrep, keeping the result of a parse * around. This type is only created from a pre-existing string, so an * updateStringProc will never be called and need not exist. The type * is unregistered, so has no need of a setFromAnyProc either. */ static const Tcl_ObjType endOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V1(TclLengthOne) }; Tcl_Size TclLengthOne( TCL_UNUSED(Tcl_Obj *)) { |
︙ | ︙ | |||
939 940 941 942 943 944 945 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_ScanElement( | | | | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_ScanElement( const char *src, /* String to convert to list element. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertCountedElement. */ { return Tcl_ScanCountedElement(src, TCL_INDEX_NONE, flagPtr); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 | int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something * needs protection or escape. */ int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some * reason bare or brace-quoted form fails. */ Tcl_Size extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ | | | 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 | int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something * needs protection or escape. */ int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some * reason bare or brace-quoted form fails. */ Tcl_Size extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ Tcl_Size bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ int preferBrace = 0; /* CONVERT_MASK mode. */ int braceCount = 0; /* Count of all braces '{' '}' seen. */ #endif /* COMPAT */ |
︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 | forbidNone = 1; #if COMPAT preferBrace = 1; #endif /* COMPAT */ } while (length) { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | forbidNone = 1; #if COMPAT preferBrace = 1; #endif /* COMPAT */ } while (length) { if (CHAR_TYPE(*p) != TYPE_NORMAL) { switch (*p) { case '{': /* TYPE_BRACE */ #if COMPAT braceCount++; #endif /* COMPAT */ extra++; /* Escape '{' => '\{' */ nestingLevel++; break; case '}': /* TYPE_BRACE */ #if COMPAT braceCount++; #endif /* COMPAT */ extra++; /* Escape '}' => '\}' */ if (nestingLevel-- < 1) { /* * Unbalanced braces! Cannot format with brace quoting. */ requireEscape = 1; } break; case ']': /* TYPE_CLOSE_BRACK */ case '"': /* TYPE_SPACE */ #if COMPAT forbidNone = 1; extra++; /* Escapes all just prepend a backslash */ preferEscape = 1; break; #else /* FLOW THROUGH */ #endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ case ';': /* TYPE_COMMAND_END */ forbidNone = 1; extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; #endif /* COMPAT */ break; case '\\': /* TYPE_SUBS */ extra++; /* Escape '\' => '\\' */ if ((length == 1) || ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) { /* * Final backslash. Cannot format with brace quoting. */ requireEscape = 1; break; } if (p[1] == '\n') { extra++; /* Escape newline => '\n', one byte longer */ /* * Backslash newline sequence. Brace quoting not permitted. */ requireEscape = 1; length -= (length > 0); p++; break; } if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) { extra++; /* Escape sequences all one byte longer. */ length -= (length > 0); p++; } forbidNone = 1; #if COMPAT preferBrace = 1; #endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ if (length == TCL_INDEX_NONE) { goto endOfString; } /* TODO: Panic on improper encoding? */ break; default: if (TclIsSpaceProcM(*p)) { forbidNone = 1; extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; #endif } break; } } length -= (length > 0); p++; } endOfString: if (nestingLevel > 0) { /* |
︙ | ︙ | |||
1316 1317 1318 1319 1320 1321 1322 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_ConvertElement( | | | | | 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_ConvertElement( const char *src, /* Source information for list element. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { return Tcl_ConvertCountedElement(src, TCL_INDEX_NONE, dst, flags); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1346 1347 1348 1349 1350 1351 1352 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_ConvertCountedElement( | | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_ConvertCountedElement( const char *src, /* Source information for list element. */ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { Tcl_Size numBytes = TclConvertElement(src, length, dst, flags); dst[numBytes] = '\0'; return numBytes; |
︙ | ︙ | |||
1379 1380 1381 1382 1383 1384 1385 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclConvertElement( | | | < | 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclConvertElement( const char *src, /* Source information for list element. */ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { int conversion = flags & CONVERT_MASK; char *p = dst; /* * Let the caller demand we use escape sequences rather than braces. */ if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) { conversion = CONVERT_ESCAPE; } /* * No matter what the caller demands, empty string must be braced! */ if ((src == NULL) || (length == 0) || (*src == '\0' && length == TCL_INDEX_NONE)) { p[0] = '{'; p[1] = '}'; return 2; } /* * Escape leading hash as needed and requested. |
︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 | * None. * *---------------------------------------------------------------------- */ char * Tcl_Merge( | | | 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 | * None. * *---------------------------------------------------------------------- */ char * Tcl_Merge( Tcl_Size argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; Tcl_Size i; size_t bytesNeeded = 0; char *result, *dst; |
︙ | ︙ | |||
1638 1639 1640 1641 1642 1643 1644 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclTrimRight( | | | | | | | | | | 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclTrimRight( const char *bytes, /* String to be trimmed... */ Tcl_Size numBytes, /* ...and its length in bytes */ /* Calls to TclUtfToUniChar() in this routine * rely on (bytes[numBytes] == '\0'). */ const char *trim, /* String of trim characters... */ Tcl_Size numTrim) /* ...and its length in bytes */ /* Calls to TclUtfToUniChar() in this routine * rely on (trim[numTrim] == '\0'). */ { const char *pp, *p = bytes + numBytes; int ch1, ch2; /* Empty strings -> nothing to do */ if ((numBytes == 0) || (numTrim == 0)) { return 0; |
︙ | ︙ | |||
1717 1718 1719 1720 1721 1722 1723 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclTrimLeft( | | | | | | | | | | 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclTrimLeft( const char *bytes, /* String to be trimmed... */ Tcl_Size numBytes, /* ...and its length in bytes */ /* Calls to TclUtfToUniChar() in this routine * rely on (bytes[numBytes] == '\0'). */ const char *trim, /* String of trim characters... */ Tcl_Size numTrim) /* ...and its length in bytes */ /* Calls to TclUtfToUniChar() in this routine * rely on (trim[numTrim] == '\0'). */ { const char *p = bytes; int ch1, ch2; /* Empty strings -> nothing to do */ if ((numBytes == 0) || (numTrim == 0)) { return 0; |
︙ | ︙ | |||
1791 1792 1793 1794 1795 1796 1797 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclTrim( | | | | | | | | | | 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclTrim( const char *bytes, /* String to be trimmed... */ Tcl_Size numBytes, /* ...and its length in bytes */ /* Calls in this routine * rely on (bytes[numBytes] == '\0'). */ const char *trim, /* String of trim characters... */ Tcl_Size numTrim, /* ...and its length in bytes */ /* Calls in this routine * rely on (trim[numTrim] == '\0'). */ Tcl_Size *trimRightPtr) /* Offset from the end of the string. */ { Tcl_Size trimLeft = 0, trimRight = 0; /* Empty strings -> nothing to do */ if ((numBytes > 0) && (numTrim > 0)) { |
︙ | ︙ | |||
1853 1854 1855 1856 1857 1858 1859 | */ /* The whitespace characters trimmed during [concat] operations */ #define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( | | | 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 | */ /* The whitespace characters trimmed during [concat] operations */ #define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( Tcl_Size argc, /* Number of strings to concatenate. */ const char *const *argv) /* Array of strings to concatenate. */ { Tcl_Size i, needSpace = 0, bytesNeeded = 0; char *result, *p; /* * Dispose of the empty result corner case first to simplify later code. |
︙ | ︙ | |||
2331 2332 2333 2334 2335 2336 2337 | * *---------------------------------------------------------------------- */ int TclByteArrayMatch( const unsigned char *string,/* String. */ | | | | 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 | * *---------------------------------------------------------------------- */ int TclByteArrayMatch( const unsigned char *string,/* String. */ Tcl_Size strLen, /* Length of String */ const unsigned char *pattern, /* Pattern, which may contain special * characters. */ Tcl_Size ptnLen, /* Length of Pattern */ TCL_UNUSED(int) /*flags*/) { const unsigned char *stringEnd, *patternEnd; unsigned char p; stringEnd = string + strLen; patternEnd = pattern + ptnLen; |
︙ | ︙ | |||
2722 2723 2724 2725 2726 2727 2728 | * We don't need a space, maybe because there's some already there. * Checking whether we might be appending a first element is a bit * more involved. * * Backtrack over all whitespace. */ while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) { | < | 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 | * We don't need a space, maybe because there's some already there. * Checking whether we might be appending a first element is a bit * more involved. * * Backtrack over all whitespace. */ while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) { } /* Call again without whitespace to confound things. */ quoteHash = !TclNeedSpace(dsPtr->string, dst+1); } if (!quoteHash) { flags |= TCL_DONT_QUOTE_HASH; |
︙ | ︙ | |||
2804 2805 2806 2807 2808 2809 2810 | * *---------------------------------------------------------------------- */ void Tcl_DStringSetLength( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ | | | 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 | * *---------------------------------------------------------------------- */ void Tcl_DStringSetLength( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ Tcl_Size length) /* New length for dynamic string. */ { Tcl_Size newsize; if (length < 0) { length = 0; } if (length >= dsPtr->spaceAvl) { |
︙ | ︙ | |||
3237 3238 3239 3240 3241 3242 3243 | end = Tcl_UtfPrev(end, start); } * */ while ((--end >= start) && (*end == '{')) { | < | | 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 | end = Tcl_UtfPrev(end, start); } * */ while ((--end >= start) && (*end == '{')) { } if (end < start) { return 0; } /* * (c) the trailing character of the string is already a list-element * separator, Use the same testing routine as TclFindElement to * enforce consistency. */ |
︙ | ︙ | |||
3294 3295 3296 3297 3298 3299 3300 | *---------------------------------------------------------------------- */ Tcl_Size TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ | | | 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 | *---------------------------------------------------------------------- */ Tcl_Size TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ Tcl_WideInt n) /* The integer to format. */ { Tcl_WideUInt intVal; int i = 0, numFormatted, j; static const char digits[] = "0123456789"; /* * Generate the characters of the result backwards in the buffer. |
︙ | ︙ | |||
3356 3357 3358 3359 3360 3361 3362 | * The type of *objPtr may change. * *---------------------------------------------------------------------- */ static int GetWideForIndex( | | | | | | | | | 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 | * The type of *objPtr may change. * *---------------------------------------------------------------------- */ static int GetWideForIndex( Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ Tcl_Obj *objPtr, /* Points to the value to be parsed */ Tcl_WideInt endValue, /* The value to be stored at *widePtr if * objPtr holds "end". * NOTE: this value may be TCL_INDEX_NONE. */ Tcl_WideInt *widePtr) /* Location filled in with a wide integer * representing an index. */ { int numType; void *cd; int code = Tcl_GetNumberFromObj(NULL, objPtr, &cd, &numType); if (code == TCL_OK) { if (numType == TCL_NUMBER_INT) { /* objPtr holds an integer in the signed wide range */ *widePtr = *(Tcl_WideInt *)cd; if ((*widePtr < 0)) { *widePtr = (endValue == -1) ? WIDE_MIN : -1; } return TCL_OK; } if (numType == TCL_NUMBER_BIG) { /* objPtr holds an integer outside the signed wide range */ /* Truncate to the signed wide range. */ |
︙ | ︙ | |||
3405 3406 3407 3408 3409 3410 3411 | * integer([+-]integer)? or end([+-]integer)?. * * If the computed index lies within the valid range of Tcl indices * (0..TCL_SIZE_MAX) it is returned. Higher values are returned as * TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1). * * Callers should pass reasonable values for endValue - one in the | | | 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 | * integer([+-]integer)? or end([+-]integer)?. * * If the computed index lies within the valid range of Tcl indices * (0..TCL_SIZE_MAX) it is returned. Higher values are returned as * TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1). * * Callers should pass reasonable values for endValue - one in the * valid index range or TCL_INDEX_NONE (-1), for example for an empty * list. * * Results: * TCL_OK * * The index is stored at the address given by by 'indexPtr'. * |
︙ | ︙ | |||
3449 3450 3451 3452 3453 3454 3455 | if (indexPtr != NULL) { /* Note: check against TCL_SIZE_MAX needed for 32-bit builds */ if (wide >= 0 && wide <= TCL_SIZE_MAX) { *indexPtr = (Tcl_Size)wide; /* A valid index */ } else if (wide > TCL_SIZE_MAX) { *indexPtr = TCL_SIZE_MAX; /* Beyond max possible index */ } else if (wide < -1-TCL_SIZE_MAX) { | | | | | | 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 | if (indexPtr != NULL) { /* Note: check against TCL_SIZE_MAX needed for 32-bit builds */ if (wide >= 0 && wide <= TCL_SIZE_MAX) { *indexPtr = (Tcl_Size)wide; /* A valid index */ } else if (wide > TCL_SIZE_MAX) { *indexPtr = TCL_SIZE_MAX; /* Beyond max possible index */ } else if (wide < -1-TCL_SIZE_MAX) { *indexPtr = -1-TCL_SIZE_MAX; /* Below most negative index */ } else if ((wide < 0) && (endValue >= 0)) { *indexPtr = TCL_INDEX_NONE; /* No clue why this special case */ } else { *indexPtr = (Tcl_Size) wide; } } return TCL_OK; } /* |
︙ | ︙ | |||
3476 3477 3478 3479 3480 3481 3482 | * WIDE_MIN: Index value TCL_INDEX_NONE (or -1) * WIDE_MIN+1: Index value n, for any n < -1 (usually same effect as -1) * -$n: Index "end-[expr {$n-1}]" * -2: Index "end-1" * -1: Index "end" * 0: Index "0" * WIDE_MAX-1: Index "end+n", for any n > 1. Distinguish from end+1 for | | | | | | | | 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 | * WIDE_MIN: Index value TCL_INDEX_NONE (or -1) * WIDE_MIN+1: Index value n, for any n < -1 (usually same effect as -1) * -$n: Index "end-[expr {$n-1}]" * -2: Index "end-1" * -1: Index "end" * 0: Index "0" * WIDE_MAX-1: Index "end+n", for any n > 1. Distinguish from end+1 for * commands like lset. * WIDE_MAX: Index "end+1" * * Results: * Tcl return code. * * Side effects: * May store a Tcl_ObjType. * *---------------------------------------------------------------------- */ static int GetEndOffsetFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr, /* Pointer to the object to parse */ Tcl_WideInt endValue, /* The value to be stored at "widePtr" if * "objPtr" holds "end". */ Tcl_WideInt *widePtr) /* Location filled in with an integer * representing an index. */ { Tcl_ObjInternalRep *irPtr; Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */ void *cd; while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) { Tcl_ObjInternalRep ir; |
︙ | ︙ | |||
3528 3529 3530 3531 3532 3533 3534 | /* * Quick scan to see if multi-value list is even possible. * This relies on TclGetString() returning a NUL-terminated string. */ if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1) /* If it's possible, do the full list parse. */ | | | | | | | 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 | /* * Quick scan to see if multi-value list is even possible. * This relies on TclGetString() returning a NUL-terminated string. */ if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1) /* If it's possible, do the full list parse. */ && (TCL_OK == TclListObjLength(NULL, objPtr, &length)) && (length > 1)) { goto parseError; } /* Passed the list screen, so parse for index arithmetic expression */ if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, &opPtr, TCL_PARSE_INTEGER_ONLY)) { Tcl_WideInt w1=0, w2=0; /* value starts with valid integer... */ if ((*opPtr == '-') || (*opPtr == '+')) { /* ... value continues with [-+] ... */ |
︙ | ︙ | |||
3694 3695 3696 3697 3698 3699 3700 | } offset = irPtr->wideValue; if (offset == WIDE_MAX) { /* * Encodes end+1. This is distinguished from end+n as noted | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 | } offset = irPtr->wideValue; if (offset == WIDE_MAX) { /* * Encodes end+1. This is distinguished from end+n as noted * in function header. * NOTE: this may wrap around if the caller passes (as lset does) * listLen-1 as endValue and and listLen is 0. The -1 will be * interpreted as FF...FF and adding 1 will result in 0 which * is what we want. Callers like lset which pass in listLen-1 == -1 * as endValue will have to adjust accordingly. */ *widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1; } else if (offset == WIDE_MIN) { /* -1 - position before first */ *widePtr = -1; } else if (offset < 0) { /* end-(n-1) - Different signs, sum cannot overflow */ *widePtr = endValue + offset + 1; } else if (offset < WIDE_MAX) { /* 0:WIDE_MAX-1 - plain old index. */ *widePtr = offset; } else { /* Huh, what case remains here? */ *widePtr = WIDE_MAX; } return TCL_OK; /* Report a parse error. */ parseError: if (interp != NULL) { char *bytes = TclGetString(objPtr); TclPrintfResult(interp, "bad index \"%s\": must be integer?[+-]integer? or" " end?[+-]integer?", bytes); if (!strncmp(bytes, "end-", 4)) { bytes += 4; } Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (char *)NULL); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclIndexEncode -- * IMPORTANT: function only encodes indices in the range that fits within * an "int" type. Do NOT change this as the byte code compiler and engine * which call this function cannot handle wider index types. Indices * outside the range will result in the function returning an error. * * Parse objPtr to determine if it is an index value. Two cases * are possible. The value objPtr might be parsed as an absolute * index value in the Tcl_Size range. Note that this includes * index values that are integers as presented and it includes index * arithmetic expressions. * * The largest string supported in Tcl 8 has byte length TCL_SIZE_MAX. * This means the largest supported character length is also TCL_SIZE_MAX, * and the index of the last character in a string of length TCL_SIZE_MAX * is TCL_SIZE_MAX-1. Thus the absolute index values that can be * directly meaningful as an index into either a list or a string are * integer values in the range 0 to TCL_SIZE_MAX - 1. * * This function however can only handle integer indices in the range * 0 : INT_MAX-1. * * Any absolute index value parsed outside that range is encoded * using the before and after values passed in by the * caller as the encoding to use for indices that are either * less than or greater than the usable index range. TCL_INDEX_NONE * is available as a good choice for most callers to use for * after. Likewise, the value TCL_INDEX_NONE is good for * most callers to use for before. Other values are possible * when the caller knows it is helpful in producing its own behavior * for indices before and after the indexed item. * * A token can also be parsed as an end-relative index expression. * All end-relative expressions that indicate an index larger * than end (end+2, end--5) point beyond the end of the indexed * collection, and can be encoded as after. The end-relative * expressions that indicate an index less than or equal to end * are encoded relative to the value TCL_INDEX_END (-2). The * index "end" is encoded as -2, down to the index "end-0x7FFFFFFE" * which is encoded as INT_MIN. Since the largest index into a * string possible in Tcl 8 is 0x7FFFFFFE, the interpretation of * "end-0x7FFFFFFE" for that largest string would be 0. Thus, * if the tokens "end-0x7FFFFFFF" or "end+-0x80000000" are parsed, * they can be encoded with the before value. * * Returns: * TCL_OK if parsing succeeded, and TCL_ERROR if it failed or the * index does not fit in an int type. * * Side effects: * When TCL_OK is returned, the encoded index value is written * to *indexPtr. * *---------------------------------------------------------------------- */ int TclIndexEncode( Tcl_Interp *interp, /* For error reporting, may be NULL */ Tcl_Obj *objPtr, /* Index value to parse */ int before, /* Value to return for index before beginning */ int after, /* Value to return for index after end */ int *indexPtr) /* Where to write the encoded answer, not NULL */ { Tcl_WideInt wide; int idx; const Tcl_WideInt ENDVALUE = 2 * (Tcl_WideInt) INT_MAX; assert(ENDVALUE < WIDE_MAX); if (TCL_OK != GetWideForIndex(interp, objPtr, ENDVALUE, &wide)) { |
︙ | ︙ | |||
3941 3942 3943 3944 3945 3946 3947 | * The decoded index value. * *---------------------------------------------------------------------- */ Tcl_Size TclIndexDecode( | | | | 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 | * The decoded index value. * *---------------------------------------------------------------------- */ Tcl_Size TclIndexDecode( int encoded, /* Value to decode */ Tcl_Size endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ { if (encoded > TCL_INDEX_END) { return encoded; } endValue += encoded - TCL_INDEX_END; if (endValue >= 0) { return endValue; |
︙ | ︙ | |||
3971 3972 3973 3974 3975 3976 3977 | * Side effects: * If interp is not-NULL, an error message is stored in it. * *------------------------------------------------------------------------ */ int TclCommandWordLimitError( | | | | 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 | * Side effects: * If interp is not-NULL, an error message is stored in it. * *------------------------------------------------------------------------ */ int TclCommandWordLimitError( Tcl_Interp *interp, /* May be NULL */ Tcl_Size count) /* If <= 0, "unknown" */ { if (interp) { if (count > 0) { TclPrintfResult(interp, "Number of words (%" TCL_SIZE_MODIFIER "d) in command exceeds limit %" TCL_SIZE_MODIFIER "d.", count, (Tcl_Size)INT_MAX); |
︙ | ︙ | |||
4038 4039 4040 4041 4042 4043 4044 | *---------------------------------------------------------------------- */ static Tcl_HashTable * GetThreadHash( Tcl_ThreadDataKey *keyPtr) { | | | | | 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 | *---------------------------------------------------------------------- */ static Tcl_HashTable * GetThreadHash( Tcl_ThreadDataKey *keyPtr) { Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **)Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *)); if (NULL == *tablePtrPtr) { *tablePtrPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr); Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); } return *tablePtrPtr; } /* |
︙ | ︙ | |||
4235 4236 4237 4238 4239 4240 4241 | /* * If no thread has set the shared value, call the initializer. */ Tcl_MutexLock(&pgvPtr->mutex); if ((NULL == pgvPtr->value) && (pgvPtr->proc)) { pgvPtr->epoch++; | | | 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 | /* * If no thread has set the shared value, call the initializer. */ Tcl_MutexLock(&pgvPtr->mutex); if ((NULL == pgvPtr->value) && (pgvPtr->proc)) { pgvPtr->epoch++; pgvPtr->proc(&pgvPtr->value,&pgvPtr->numBytes,&pgvPtr->encoding); if (pgvPtr->value == NULL) { Tcl_Panic("PGV Initializer did not initialize"); } Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } /* |
︙ | ︙ |
Changes to generic/tclVar.c.
︙ | ︙ | |||
248 249 250 251 252 253 254 | static const Tcl_ObjType localVarNameType = { "localVarName", FreeLocalVarName, DupLocalVarName, NULL, NULL, TCL_OBJTYPE_V0 }; | | | | | | | | | | | | | | | 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 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 | static const Tcl_ObjType localVarNameType = { "localVarName", FreeLocalVarName, DupLocalVarName, NULL, NULL, TCL_OBJTYPE_V0 }; #define LocalSetInternalRep(objPtr, index, namePtr) \ do { \ Tcl_ObjInternalRep ir; \ Tcl_Obj *ptr = (namePtr); \ if (ptr) {Tcl_IncrRefCount(ptr);} \ ir.twoPtrValue.ptr1 = ptr; \ ir.twoPtrValue.ptr2 = INT2PTR(index); \ Tcl_StoreInternalRep((objPtr), &localVarNameType, &ir); \ } while (0) #define LocalGetInternalRep(objPtr, index, name) \ do { \ const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &localVarNameType); \ (name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \ (index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE; \ } while (0) static const Tcl_ObjType parsedVarNameType = { "parsedVarName", FreeParsedVarName, DupParsedVarName, NULL, NULL, TCL_OBJTYPE_V0 }; #define ParsedSetInternalRep(objPtr, arrayPtr, elem) \ do { \ Tcl_ObjInternalRep ir; \ Tcl_Obj *ptr1 = (arrayPtr); \ Tcl_Obj *ptr2 = (elem); \ if (ptr1) {Tcl_IncrRefCount(ptr1);} \ if (ptr2) {Tcl_IncrRefCount(ptr2);} \ ir.twoPtrValue.ptr1 = ptr1; \ ir.twoPtrValue.ptr2 = ptr2; \ Tcl_StoreInternalRep((objPtr), &parsedVarNameType, &ir); \ } while (0) #define ParsedGetInternalRep(objPtr, parsed, array, elem) \ do { \ const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &parsedVarNameType); \ (parsed) = (irPtr != NULL); \ (array) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \ (elem) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \ } while (0) Var * TclVarHashCreateVar( TclVarHashTable *tablePtr, const char *key, int *newPtr) |
︙ | ︙ | |||
526 527 528 529 530 531 532 | * *---------------------------------------------------------------------- */ Var * TclObjLookupVar( Tcl_Interp *interp, /* Interpreter to use for lookup. */ | | | | | 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 | * *---------------------------------------------------------------------- */ Var * TclObjLookupVar( Tcl_Interp *interp, /* Interpreter to use for lookup. */ Tcl_Obj *part1Ptr, /* If part2 isn't NULL, this is the name of an * array. Otherwise, this is a full variable * name that could include a parenthesized * array element. */ const char *part2, /* Name of element within array, or NULL. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * and TCL_LEAVE_ERR_MSG bits matter. */ const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ int createPart1, /* If 1, create hash table entry for part 1 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ int createPart2, /* If 1, create hash table entry for part 2 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var **arrayPtrPtr) /* If the name refers to an element of an * array, *arrayPtrPtr gets filled in with * address of array variable. Otherwise this * is set to NULL. */ { |
︙ | ︙ | |||
586 587 588 589 590 591 592 | * parenthesized array element. */ Tcl_Obj *part2Ptr, /* Name of element within array, or NULL. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * and TCL_LEAVE_ERR_MSG bits matter. */ const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ | | | | | 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 | * parenthesized array element. */ Tcl_Obj *part2Ptr, /* Name of element within array, or NULL. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * and TCL_LEAVE_ERR_MSG bits matter. */ const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ int createPart1, /* If 1, create hash table entry for part 1 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ int createPart2, /* If 1, create hash table entry for part 2 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var **arrayPtrPtr) /* If the name refers to an element of an * array, *arrayPtrPtr gets filled in with * address of array variable. Otherwise this * is set to NULL. */ { Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; Var *varPtr; /* Points to the variable's in-frame Var * structure. */ const char *errMsg = NULL; int index, parsed = 0; Tcl_Size localIndex; Tcl_Obj *namePtr, *arrayPtr, *elem; |
︙ | ︙ | |||
822 823 824 825 826 827 828 | TclLookupSimpleVar( Tcl_Interp *interp, /* Interpreter to use for lookup. */ Tcl_Obj *varNamePtr, /* This is a simple variable name that could * represent a scalar or an array. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG * bits matter. */ | | | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 | TclLookupSimpleVar( Tcl_Interp *interp, /* Interpreter to use for lookup. */ Tcl_Obj *varNamePtr, /* This is a simple variable name that could * represent a scalar or an array. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG * bits matter. */ int create, /* If 1, create hash table entry for varname, * if it doesn't already exist. If 0, return * error if it doesn't exist. */ const char **errMsgPtr, int *indexPtr) { Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; |
︙ | ︙ | |||
1020 1021 1022 1023 1024 1025 1026 | * TclLookupArrayElement -- * * This function is used to locate a variable which is in an array's * hashtable given a pointer to the array's Var structure and the * element's name. * * Results: | | | 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 | * TclLookupArrayElement -- * * This function is used to locate a variable which is in an array's * hashtable given a pointer to the array's Var structure and the * element's name. * * Results: * The return value is a pointer to the variable structure , or NULL if * the variable couldn't be found. * * If arrayPtr points to a variable that isn't an array and createPart1 * is 1, the corresponding variable will be converted to an array. * Otherwise, NULL is returned and an error message is left in the * interp's result if TCL_LEAVE_ERR_MSG is set in flags. * |
︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 | Var * TclLookupArrayElement( Tcl_Interp *interp, /* Interpreter to use for lookup. */ Tcl_Obj *arrayNamePtr, /* This is the name of the array, or NULL if * index>= 0. */ Tcl_Obj *elNamePtr, /* Name of element within array. */ | | | | | 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 | Var * TclLookupArrayElement( Tcl_Interp *interp, /* Interpreter to use for lookup. */ Tcl_Obj *arrayNamePtr, /* This is the name of the array, or NULL if * index>= 0. */ Tcl_Obj *elNamePtr, /* Name of element within array. */ int flags, /* Only TCL_LEAVE_ERR_MSG bit matters. */ const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ int createArray, /* If 1, transform arrayName to be an array if * it isn't one yet and the transformation is * possible. If 0, return error if it isn't * already an array. */ int createElem, /* If 1, create hash table entry for the * element, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var *arrayPtr, /* Pointer to the array's Var structure. */ int index) /* If >=0, the index of the local array. */ { int isNew; Var *varPtr; |
︙ | ︙ | |||
1272 1273 1274 1275 1276 1277 1278 | *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_ObjGetVar2( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ | | | | 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 | *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_ObjGetVar2( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ Tcl_Obj *part1Ptr, /* Points to an object holding the name of an * array (if part2 is non-NULL) or the name of * a variable. */ Tcl_Obj *part2Ptr, /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and * TCL_LEAVE_ERR_MSG bits. */ { Var *varPtr, *arrayPtr; |
︙ | ︙ | |||
1331 1332 1333 1334 1335 1336 1337 | Tcl_Var varPtr, /* The variable to be read.*/ Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ | | | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 | Tcl_Var varPtr, /* The variable to be read.*/ Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* 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. */ { if (varPtr == NULL) { Tcl_Panic("varPtr must not be NULL"); } if (part1Ptr == NULL) { Tcl_Panic("part1Ptr must not be NULL"); |
︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 | *---------------------------------------------------------------------- */ Tcl_Obj * TclPtrGetVarIdx( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ | | | | 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 | *---------------------------------------------------------------------- */ Tcl_Obj * TclPtrGetVarIdx( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ Var *varPtr, /* The variable to be read.*/ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* 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. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { Interp *iPtr = (Interp *) interp; const char *msg; |
︙ | ︙ | |||
1478 1479 1480 1481 1482 1483 1484 | * *---------------------------------------------------------------------- */ int Tcl_SetObjCmd( TCL_UNUSED(void *), | | | | 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 | * *---------------------------------------------------------------------- */ int Tcl_SetObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *varValueObj; if (objc == 2) { varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL,TCL_LEAVE_ERR_MSG); if (varValueObj == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, varValueObj); return TCL_OK; } else if (objc == 3) { varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2], |
︙ | ︙ | |||
1655 1656 1657 1658 1659 1660 1661 | *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_ObjSetVar2( Tcl_Interp *interp, /* Command interpreter in which variable is to * be found. */ | | | | 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 | *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_ObjSetVar2( Tcl_Interp *interp, /* Command interpreter in which variable is to * be found. */ Tcl_Obj *part1Ptr, /* Points to an object holding the name of an * array (if part2 is non-NULL) or the name of * a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, points to an object holding * the name of an element in the array * part1Ptr. */ Tcl_Obj *newValuePtr, /* New value for variable. */ int flags) /* Various flags that tell how to set value: * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or * TCL_LEAVE_ERR_MSG. */ |
︙ | ︙ | |||
1726 1727 1728 1729 1730 1731 1732 | * variable, or NULL if the variable is a * scalar. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr, /* New value for variable. */ | | | 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 | * variable, or NULL if the variable is a * scalar. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr, /* New value for variable. */ int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { if (varPtr == NULL) { Tcl_Panic("varPtr must not be NULL"); } if (part1Ptr == NULL) { Tcl_Panic("part1Ptr must not be NULL"); |
︙ | ︙ | |||
1895 1896 1897 1898 1899 1900 1901 | *---------------------------------------------------------------------- */ Tcl_Obj * TclPtrSetVarIdx( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ | | | | 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 | *---------------------------------------------------------------------- */ Tcl_Obj * TclPtrSetVarIdx( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ Var *varPtr, /* Reference to the variable to set. */ Var *arrayPtr, /* Reference to the array containing the * variable, or NULL if the variable is a * scalar. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. NULL if the 'index' * parameter is >= 0 */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr, /* New value for variable. */ int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ int index) /* Index of local var where part1 is to be * found. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; |
︙ | ︙ | |||
1944 1945 1946 1947 1948 1949 1950 | } /* * It's an error to try to set a constant. */ if (TclIsVarConstant(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { | | | | 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 | } /* * It's an error to try to set a constant. */ if (TclIsVarConstant(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISCONST,index); Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL); } goto earlyError; } /* * It's an error to try to set an array variable itself. */ if (TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISARRAY,index); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (char *)NULL); } goto earlyError; } TclVarFindHiddenArray(varPtr, arrayPtr); |
︙ | ︙ | |||
2164 2165 2166 2167 2168 2169 2170 | * array (if part2 is non-NULL) or the name of * a variable. */ Tcl_Obj *part2Ptr, /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value. */ /* TODO: Which of these flag values really make sense? */ | | | 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 | * array (if part2 is non-NULL) or the name of * a variable. */ Tcl_Obj *part2Ptr, /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value. */ /* TODO: Which of these flag values really make sense? */ int flags) /* Various flags that tell how to incr value: * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ { if (varPtr == NULL) { Tcl_Panic("varPtr must not be NULL"); } |
︙ | ︙ | |||
2220 2221 2222 2223 2224 2225 2226 | * array (if part2 is non-NULL) or the name of * a variable. */ Tcl_Obj *part2Ptr, /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value. */ /* TODO: Which of these flag values really make sense? */ | | | | 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 | * array (if part2 is non-NULL) or the name of * a variable. */ Tcl_Obj *part2Ptr, /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value. */ /* TODO: Which of these flag values really make sense? */ int flags, /* Various flags that tell how to incr value: * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { Tcl_Obj *varValuePtr; /* * It's an error to try to increment a constant. */ if (TclIsVarConstant(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "incr", ISCONST,index); Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL); } return NULL; } if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; |
︙ | ︙ | |||
2409 2410 2411 2412 2413 2414 2415 | Tcl_Var varPtr, /* The variable to be unset. */ Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ | | | 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 | Tcl_Var varPtr, /* The variable to be unset. */ Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ int flags) /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ { if (varPtr == NULL) { Tcl_Panic("varPtr must not be NULL"); } if (part1Ptr == NULL) { |
︙ | ︙ | |||
2472 2473 2474 2475 2476 2477 2478 | Var *initialArrayPtr = arrayPtr; /* * It's an error to try to unset a constant. */ if (TclIsVarConstant(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { | | | 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 | Var *initialArrayPtr = arrayPtr; /* * It's an error to try to unset a constant. */ if (TclIsVarConstant(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", ISCONST,index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "CONST", (void *)NULL); } return TCL_ERROR; } /* * Keep the variable alive until we're done with it. We used to |
︙ | ︙ | |||
2500 2501 2502 2503 2504 2505 2506 | /* * It's an error to unset an undefined variable. */ if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", | | < | 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 | /* * It's an error to unset an undefined variable. */ if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", ((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", (char *)NULL); } } /* * Finally, if the variable is truly not in use then free up its Var * structure and remove it from its hash table, if any. The ref count of |
︙ | ︙ | |||
2610 2611 2612 2613 2614 2615 2616 | Tcl_SetHashValue(tPtr, tracePtr); } } if ((dummyVar.flags & VAR_TRACED_UNSET) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) { | | | | | | | | | | | | | | | 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 | Tcl_SetHashValue(tPtr, tracePtr); } } if ((dummyVar.flags & VAR_TRACED_UNSET) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) { /* * Pass the array element name to TclObjCallVarTraces(), because * it cannot be determined from dummyVar. Alternatively, indicate * via flags whether the variable involved in the code that caused * the trace to be triggered was an array element, for the correct * formatting of error messages. */ if (part2Ptr) { flags |= VAR_ARRAY_ELEMENT; } else if (TclIsVarArrayElement(varPtr)) { part2Ptr = VarHashGetKey(varPtr); } dummyVar.flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT)) | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0, index); /* * The traces that we just called may have triggered a change in * the set of traces. If so, reload the traces to manipulate. */ |
︙ | ︙ | |||
2809 2810 2811 2812 2813 2814 2815 | if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?"); return TCL_ERROR; } if (objc == 2) { | | | 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 | if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?"); return TCL_ERROR; } if (objc == 2) { varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL,TCL_LEAVE_ERR_MSG); if (varValuePtr == NULL) { return TCL_ERROR; } } else { varPtr = TclObjLookupVarEx(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { |
︙ | ︙ | |||
4293 4294 4295 4296 4297 4298 4299 | int objc, Tcl_Obj *const objv[]) { Var *varPtr, *varPtr2, *protectedVarPtr; Tcl_Obj *varNameObj, *patternObj, *nameObj; Tcl_HashSearch search; const char *pattern; | | | 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 | int objc, Tcl_Obj *const objv[]) { Var *varPtr, *varPtr2, *protectedVarPtr; Tcl_Obj *varNameObj, *patternObj, *nameObj; Tcl_HashSearch search; const char *pattern; int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ int isArray; switch (objc) { case 2: varNameObj = objv[1]; patternObj = NULL; break; |
︙ | ︙ | |||
4472 4473 4474 4475 4476 4477 4478 | ObjMakeUpvar( Tcl_Interp *interp, /* Interpreter containing variables. Used for * error messages, too. */ CallFrame *framePtr, /* Call frame containing "other" variable. * NULL means use global :: context. */ Tcl_Obj *otherP1Ptr, const char *otherP2, /* Two-part name of variable in framePtr. */ | | | 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 | ObjMakeUpvar( Tcl_Interp *interp, /* Interpreter containing variables. Used for * error messages, too. */ CallFrame *framePtr, /* Call frame containing "other" variable. * NULL means use global :: context. */ Tcl_Obj *otherP1Ptr, const char *otherP2, /* Two-part name of variable in framePtr. */ int otherFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of "other" variable. */ Tcl_Obj *myNamePtr, /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ int myFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of myName. */ int index) /* If the variable to be linked is an indexed * scalar, this is its index. Otherwise, -1 */ |
︙ | ︙ | |||
4518 4519 4520 4521 4522 4523 4524 | * local variable in a procedure. If we allowed this, the local * variable in the shorter-lived procedure frame could go away leaving * the namespace var's reference invalid. */ if (index < 0) { if (!(arrayPtr != NULL | | | | 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 | * local variable in a procedure. If we allowed this, the local * variable in the shorter-lived procedure frame could go away leaving * the namespace var's reference invalid. */ if (index < 0) { if (!(arrayPtr != NULL ? (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) : (TclIsVarInHash(otherPtr) && TclGetVarNsPtr(otherPtr))) && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) || (varFramePtr == NULL) || !HasLocalVars(varFramePtr) || (strstr(TclGetString(myNamePtr), "::") != NULL))) { TclPrintfResult((Tcl_Interp *) iPtr, "bad variable name \"%s\": can't create namespace " "variable that refers to procedure variable", |
︙ | ︙ | |||
5326 5327 5328 5329 5330 5331 5332 | * *---------------------------------------------------------------------- */ static void DeleteSearches( Interp *iPtr, | | | 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 | * *---------------------------------------------------------------------- */ static void DeleteSearches( Interp *iPtr, Var *arrayVarPtr) /* Variable whose searches are to be * deleted. */ { ArraySearch *searchPtr, *nextPtr; Tcl_HashEntry *sPtr; if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) { sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr); |
︙ | ︙ | |||
5599 5600 5601 5602 5603 5604 5605 | */ if (elPtr->flags & VAR_TRACED_UNSET) { Tcl_Obj *elNamePtr = VarHashGetKey(elPtr); elPtr->flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr, | | | 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 | */ if (elPtr->flags & VAR_TRACED_UNSET) { Tcl_Obj *elNamePtr = VarHashGetKey(elPtr); elPtr->flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr, elNamePtr, flags,/* leaveErrMsg */ 0, index); } tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr); tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); while (tracePtr) { VarTrace *prevPtr = tracePtr; tracePtr = tracePtr->nextPtr; |
︙ | ︙ | |||
6794 6795 6796 6797 6798 6799 6800 | VarHashRefCount(varPtr)--; } Tcl_DecrRefCount(objPtr); } static int CompareVarKeys( | | | 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 | VarHashRefCount(varPtr)--; } Tcl_DecrRefCount(objPtr); } static int CompareVarKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr; Tcl_Obj *objPtr2 = hPtr->key.objPtr; const char *p1, *p2; size_t l1, l2; |
︙ | ︙ | |||
7073 7074 7075 7076 7077 7078 7079 | * * array default set v 1 * lappend v(a) 2; # returns a new object {1 2} * set v(b); # returns the original default object "1" */ if (tablePtr->defaultObj) { | | | | | | 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 | * * array default set v 1 * lappend v(a) 2; # returns a new object {1 2} * set v(b); # returns the original default object "1" */ if (tablePtr->defaultObj) { Tcl_DecrRefCount(tablePtr->defaultObj); Tcl_DecrRefCount(tablePtr->defaultObj); } tablePtr->defaultObj = defaultObj; if (tablePtr->defaultObj) { Tcl_IncrRefCount(tablePtr->defaultObj); Tcl_IncrRefCount(tablePtr->defaultObj); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclZipfs.c.
︙ | ︙ | |||
41 42 43 44 45 46 47 | #include <dlfcn.h> #endif /* * Macros to report errors only if an interp is present. */ | | | | | 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 | #include <dlfcn.h> #endif /* * Macros to report errors only if an interp is present. */ #define ZIPFS_ERROR(interp,errstr) \ do { \ if (interp) { \ TclSetResult(interp, errstr); \ } \ } while (0) #define ZIPFS_MEM_ERROR(interp) \ do { \ if (interp) { \ TclSetResult(interp, "out of memory"); \ Tcl_SetErrorCode(interp, "TCL", "MALLOC", (char *)NULL); \ } \ } while (0) #define ZIPFS_POSIX_ERROR(interp,errstr) \ do { \ if (interp) { \ TclPrintfResult(interp, \ "%s: %s", errstr, Tcl_PosixError(interp)); \ } \ } while (0) #define ZIPFS_ERROR_CODE(interp,errcode) \ do { \ if (interp) { \ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, (char *)NULL); \ } \ } while (0) #ifdef HAVE_ZLIB |
︙ | ︙ | |||
191 192 193 194 195 196 197 | unsigned char *data; /* Memory mapped or malloc'ed file */ size_t length; /* Length of memory mapped file */ void *ptrToFree; /* Non-NULL if malloc'ed file */ size_t numFiles; /* Number of files in archive */ size_t baseOffset; /* Archive start */ size_t passOffset; /* Password start */ size_t directoryOffset; /* Archive directory start */ | | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 | unsigned char *data; /* Memory mapped or malloc'ed file */ size_t length; /* Length of memory mapped file */ void *ptrToFree; /* Non-NULL if malloc'ed file */ size_t numFiles; /* Number of files in archive */ size_t baseOffset; /* Archive start */ size_t passOffset; /* Password start */ size_t directoryOffset; /* Archive directory start */ size_t directorySize; /* Size of archive directory */ unsigned char passBuf[264]; /* Password buffer */ size_t numOpen; /* Number of open files on archive */ struct ZipEntry *entries; /* List of files in archive */ struct ZipEntry *topEnts; /* List of top-level dirs in archive */ char *mountPoint; /* Mount point name */ Tcl_Size mountPointLen; /* Length of mount point name */ #ifdef _WIN32 |
︙ | ︙ | |||
253 254 255 256 257 258 259 | ZipFile *zipFilePtr; /* The ZIP file holding this channel */ ZipEntry *zipEntryPtr; /* Pointer back to virtual file */ Tcl_Size maxWrite; /* Maximum size for write */ Tcl_Size numBytes; /* Number of bytes of uncompressed data */ Tcl_Size cursor; /* Seek position for next read or write*/ unsigned char *ubuf; /* Pointer to the uncompressed data */ unsigned char *ubufToFree; /* NULL if ubuf points to memory that does not | | | | | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 | ZipFile *zipFilePtr; /* The ZIP file holding this channel */ ZipEntry *zipEntryPtr; /* Pointer back to virtual file */ Tcl_Size maxWrite; /* Maximum size for write */ Tcl_Size numBytes; /* Number of bytes of uncompressed data */ Tcl_Size cursor; /* Seek position for next read or write*/ unsigned char *ubuf; /* Pointer to the uncompressed data */ unsigned char *ubufToFree; /* NULL if ubuf points to memory that does not need freeing. Else memory to free (ubuf may point *inside* the block) */ Tcl_Size ubufSize; /* Size of allocated ubufToFree */ int iscompr; /* True if data is compressed */ int isDirectory; /* Set to 1 if directory, or -1 if root */ int isEncrypted; /* True if data is encrypted */ int mode; /* O_WRITE, O_APPEND, O_TRUNC etc.*/ unsigned long keys[3]; /* Key for decryption */ } ZipChannel; static inline int |
︙ | ︙ | |||
1387 1388 1389 1390 1391 1392 1393 | * is accepted. Note that we do not support ZIP64. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed * into the given "interp" if it is not NULL. * * Side effects: | | | | | 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 | * is accepted. Note that we do not support ZIP64. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed * into the given "interp" if it is not NULL. * * Side effects: * The given ZipFile struct is filled with information about the ZIP * archive file. On error, ZipFSCloseArchive is called on zf but * it is not freed. * *------------------------------------------------------------------------- */ static int ZipFSFindTOC( Tcl_Interp *interp, /* Current interpreter. NULLable. */ |
︙ | ︙ | |||
1588 1589 1590 1591 1592 1593 1594 | * buffer. The ZIP archive header is verified and must be valid for the * function to succeed. When "needZip" is zero an embedded ZIP archive in * an executable file is accepted. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed * into the given "interp" if it is not NULL. On error, ZipFSCloseArchive | | | 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 | * buffer. The ZIP archive header is verified and must be valid for the * function to succeed. When "needZip" is zero an embedded ZIP archive in * an executable file is accepted. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed * into the given "interp" if it is not NULL. On error, ZipFSCloseArchive * is called on zf but it is not freed. * * Side effects: * ZIP archive is memory mapped or read into allocated memory, the given * ZipFile struct is filled with information about the ZIP archive file. * *------------------------------------------------------------------------- */ |
︙ | ︙ | |||
1654 1655 1656 1657 1658 1659 1660 | */ zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); if (zf->length == (size_t) TCL_INDEX_NONE) { ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } | | | 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 | */ zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); if (zf->length == (size_t) TCL_INDEX_NONE) { ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } /* What's the magic about 64 * 1024 * 1024 ? */ if ((zf->length <= ZIP_CENTRAL_END_LEN) || (zf->length - ZIP_CENTRAL_END_LEN) > (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { ZIPFS_ERROR(interp, "illegal file size"); ZIPFS_ERROR_CODE(interp, "FILE_SIZE"); goto error; } |
︙ | ︙ | |||
2224 2225 2226 2227 2228 2229 2230 | * None. * * Side effects: * Memory associated with the mounted archive is deallocated. *------------------------------------------------------------------------ */ static void | | < | 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 | * None. * * Side effects: * Memory associated with the mounted archive is deallocated. *------------------------------------------------------------------------ */ static void CleanupMount(ZipFile *zf) /* Mount point */ { ZipEntry *z, *znext; Tcl_HashEntry *hPtr; for (z = zf->entries; z; z = znext) { znext = z->next; hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); if (hPtr) { |
︙ | ︙ | |||
3271 3272 3273 3274 3275 3276 3277 | static inline const char * ComputeNameInArchive( Tcl_Obj *pathObj, /* The path to the origin file */ Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP * archive */ const char *strip, /* A prefix to strip; may be NULL if no * stripping need be done. */ | | | 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 | static inline const char * ComputeNameInArchive( Tcl_Obj *pathObj, /* The path to the origin file */ Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP * archive */ const char *strip, /* A prefix to strip; may be NULL if no * stripping need be done. */ Tcl_Size slen) /* The length of the prefix; must be 0 if no * stripping need be done. */ { const char *name; Tcl_Size len; if (directNameObj) { name = TclGetString(directNameObj); |
︙ | ︙ | |||
5105 5106 5107 5108 5109 5110 5111 | ZipChannel *info, /* The channel to set up. */ ZipEntry *z) /* The zipped file that the channel will read * from. */ { unsigned char *ubuf = NULL; int ch; | | | | 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 | ZipChannel *info, /* The channel to set up. */ ZipEntry *z) /* The zipped file that the channel will read * from. */ { unsigned char *ubuf = NULL; int ch; info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED); info->ubuf = z->zipFilePtr->data + z->offset; info->ubufToFree = NULL; /* ubuf memory not allocated */ info->ubufSize = 0; info->isDirectory = z->isDirectory; info->isEncrypted = z->isEncrypted; info->mode = O_RDONLY; /* Caller must validate - bug [6ed3447a7e] */ assert(z->numBytes >= 0 && z->numCompressedBytes >= 0); info->numBytes = z->numBytes; if (info->isEncrypted) { assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/ if (DecodeCryptHeader(interp, z, info->keys, info->ubuf) != TCL_OK) { goto error_cleanup; } info->ubuf += ZIP_CRYPT_HDR_LEN; } if (info->iscompr) { z_stream stream; int err; unsigned int j; /* * Data to decode is compressed, and possibly encrpyted too. If * encrypted, local variable ubuf is used to hold the decrypted but |
︙ | ︙ | |||
5536 5537 5538 5539 5540 5541 5542 | return -1; } if (types) { wanted = types->type; if ((wanted & TCL_GLOB_TYPE_MOUNT) && (wanted != TCL_GLOB_TYPE_MOUNT)) { if (interp) { ZIPFS_ERROR(interp, | | | | 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 | return -1; } if (types) { wanted = types->type; if ((wanted & TCL_GLOB_TYPE_MOUNT) && (wanted != TCL_GLOB_TYPE_MOUNT)) { if (interp) { ZIPFS_ERROR(interp, "Internal error: TCL_GLOB_TYPE_MOUNT should not " "be set in conjunction with other glob types."); } return TCL_ERROR; } if ((wanted & (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE | TCL_GLOB_TYPE_MOUNT)) == 0) { /* Not looking for files,dirs,mounts. zipfs cannot have others */ return TCL_OK; |
︙ | ︙ | |||
6508 6509 6510 6511 6512 6513 6514 | */ int TclZipfs_Mount( Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(const char *), /* Path to ZIP file to mount. */ TCL_UNUSED(const char *), /* Mount point path. */ | | | 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 | */ int TclZipfs_Mount( Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(const char *), /* Path to ZIP file to mount. */ TCL_UNUSED(const char *), /* Mount point path. */ TCL_UNUSED(const char *)) /* Password for opening the ZIP, or NULL if * the ZIP is unprotected. */ { ZIPFS_ERROR(interp, "no zlib available"); ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; } |
︙ | ︙ | |||
6545 6546 6547 6548 6549 6550 6551 | const char * TclZipfs_AppHook( TCL_UNUSED(int *), /*argcPtr*/ #ifdef _WIN32 TCL_UNUSED(WCHAR ***)) /* argvPtr */ #else /* !_WIN32 */ | | | 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 | const char * TclZipfs_AppHook( TCL_UNUSED(int *), /*argcPtr*/ #ifdef _WIN32 TCL_UNUSED(WCHAR ***)) /* argvPtr */ #else /* !_WIN32 */ TCL_UNUSED(char ***)) /* Pointer to argv */ #endif /* _WIN32 */ { return NULL; } Tcl_Obj * TclZipfs_TclLibrary(void) |
︙ | ︙ |
Changes to generic/tclZlib.c.
︙ | ︙ | |||
3764 3765 3766 3767 3768 3769 3770 | if (compDictObj != NULL) { chanDataPtr->compDictObj = Tcl_DuplicateObj(compDictObj); Tcl_IncrRefCount(chanDataPtr->compDictObj); Tcl_GetBytesFromObj(NULL, chanDataPtr->compDictObj, (Tcl_Size *)NULL); } switch (format) { | | | 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 | if (compDictObj != NULL) { chanDataPtr->compDictObj = Tcl_DuplicateObj(compDictObj); Tcl_IncrRefCount(chanDataPtr->compDictObj); Tcl_GetBytesFromObj(NULL, chanDataPtr->compDictObj, (Tcl_Size *)NULL); } switch (format) { case TCL_ZLIB_FORMAT_RAW: wbits = WBITS_RAW; break; case TCL_ZLIB_FORMAT_ZLIB: wbits = WBITS_ZLIB; break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; |
︙ | ︙ |
Changes to macosx/tclMacOSXFCmd.c.
︙ | ︙ | |||
80 81 82 83 84 85 86 | static int GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, OSType *osTypePtr); static Tcl_Obj * NewOSTypeObj(const OSType newOSType); static int SetOSTypeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfOSType(Tcl_Obj *objPtr); static const Tcl_ObjType tclOSTypeType = { | | | | | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | static int GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, OSType *osTypePtr); static Tcl_Obj * NewOSTypeObj(const OSType newOSType); static int SetOSTypeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfOSType(Tcl_Obj *objPtr); static const Tcl_ObjType tclOSTypeType = { "osType", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfOSType, /* updateStringProc */ SetOSTypeFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; enum { kIsInvisible = 0x4000, }; |
︙ | ︙ | |||
685 686 687 688 689 690 691 | * OSType-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfOSType( | | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 | * OSType-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfOSType( Tcl_Obj *objPtr) /* OSType object whose string rep to * update. */ { const size_t size = TCL_UTF_MAX * 4; char *dst = Tcl_InitStringRep(objPtr, NULL, size); OSType osType = (OSType) objPtr->internalRep.wideValue; int written = 0; Tcl_Encoding encoding; |
︙ | ︙ |
Changes to macosx/tclMacOSXNotify.c.
︙ | ︙ | |||
307 308 309 310 311 312 313 | int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ | | | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; /* * The following structure is what is added to the Tcl event queue when file * handlers are ready to fire. */ |
︙ | ︙ | |||
995 996 997 998 999 1000 1001 | * Replaces any previous timer. * *---------------------------------------------------------------------- */ void TclpSetTimer( | | | 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 | * Replaces any previous timer. * *---------------------------------------------------------------------- */ void TclpSetTimer( const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { ThreadSpecificData *tsdPtr; CFRunLoopTimerRef runLoopTimer; CFTimeInterval waitTime; tsdPtr = TCL_TSD_INIT(&dataKey); runLoopTimer = tsdPtr->runLoopTimer; |
︙ | ︙ | |||
1109 1110 1111 1112 1113 1114 1115 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ | | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); if (filePtr == NULL) { filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); filePtr->fd = fd; |
︙ | ︙ | |||
1903 1904 1905 1906 1907 1908 1909 | *---------------------------------------------------------------------- */ int TclAsyncNotifier( int sigNumber, /* Signal number. */ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */ | | | 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 | *---------------------------------------------------------------------- */ int TclAsyncNotifier( int sigNumber, /* Signal number. */ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */ TCL_UNUSED(void *), /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { #if TCL_THREADS /* * WARNING: * This code most likely runs in a signal handler. Thus, |
︙ | ︙ |
Changes to tests/oo.test.
︙ | ︙ | |||
2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 | c create o } -body { lsort [info object methods o -all -private] } -cleanup { o destroy c destroy } -result $stdmethods test oo-18.1 {OO: define command support} { list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo } {1 foo {foo while executing "error foo" | > > > > > > > > > > > > > > > > > > > > > > > > | 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 | c create o } -body { lsort [info object methods o -all -private] } -cleanup { o destroy c destroy } -result $stdmethods test oo-17.15 {OO: class method list without -all (bug 36e5517a6850)} -setup { oo::class create c } -body { oo::define c { method foo {} {} method Bar {} {} private method gorp {} {} } list [lsort [info class methods c]] [lsort [info class methods c -private]] } -cleanup { c destroy } -result {foo {Bar foo}} test oo-17.16 {OO: instance method list without -all (bug 36e5517a6850)} -setup { oo::object create o } -body { oo::objdefine o { method foo {} {} method Bar {} {} private method gorp {} {} } list [lsort [info object methods o]] [lsort [info object methods o -private]] } -cleanup { o destroy } -result {foo {Bar foo}} test oo-18.1 {OO: define command support} { list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo } {1 foo {foo while executing "error foo" |
︙ | ︙ | |||
3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 | lsort {q w e r t y u i o p}; # Overwrite the Tcl stack info frame 0 } [c new] test } -match glob -cleanup { c destroy } -result {* cmd {info frame 0} method test class ::c level 0} # Prove that the issue in [Bug 1865054] isn't an issue any more test oo-23.1 {Self-like derivation; complex case!} -setup { oo::class create SELF { superclass oo::class unexport create new # Next is just a convenience | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 | lsort {q w e r t y u i o p}; # Overwrite the Tcl stack info frame 0 } [c new] test } -match glob -cleanup { c destroy } -result {* cmd {info frame 0} method test class ::c level 0} # Common code for oo-22.{3,4,5,6} oo::class create WorkerBase oo::class create WorkerSupport { superclass oo::class WorkerBase variable result stop method WithWorkers {nworkers args script} { set workers {} try { for {set n 1} {$n <= $nworkers} {incr n} { lappend workers [set worker [[self] new]] $worker schedule {*}$args } return [uplevel 1 $script] } finally { foreach worker $workers {$worker destroy} } } method run {nworkers} { set result {} set stopvar [my varname stop] set stop false my WithWorkers $nworkers [list my Work [my varname result]] { after idle [namespace code {set stop true}] vwait $stopvar } return $result } } oo::class create Worker { superclass WorkerBase method schedule {args} { set coro [namespace current]::coro if {![llength [info commands $coro]]} { coroutine $coro {*}$args } } method Work args {error unimplemented} method dump {} { info frame [expr {[info frame] - 1}] } } test oo-22.3 {OO and coroutines and info frame: Bug 87271f7cd6} -body { # Triggers a crash with incorrectly restored pmPtr->procPtr->cmdPtr WorkerSupport create A { superclass Worker method Work {var} { after 0 [info coroutine] yield lappend $var [my dump] } } A run 2 } -cleanup { catch {rename dump {}} catch {A destroy} } -match glob -result {{* method Work class ::A *} {* method Work class ::A *}} test oo-22.4 {OO and coroutines and info frame: Bug 87271f7cd6} -body { # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr WorkerSupport create A { superclass Worker method Work {var} { after 0 [info coroutine] yield lappend $var [my dump] } } # Copies the methods, changing the declarer # Test it works with the source class still around oo::copy A B B run 2 } -cleanup { catch {rename dump {}} catch {A destroy} catch {B destroy} } -match glob -result {{* method Work class ::B *} {* method Work class ::B *}} test oo-22.5 {OO and coroutines and info frame: Bug 87271f7cd6} -body { # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr WorkerSupport create A { superclass Worker method Work {var} { after 0 [info coroutine] yield lappend $var [my dump] } } # Copies the methods, changing the declarer # Test it works with the source class deleted oo::copy A B catch {A destroy} B run 2 } -cleanup { catch {rename dump {}} catch {B destroy} } -match glob -result {{* method Work class ::B *} {* method Work class ::B *}} test oo-22.6 {OO and coroutines and info frame: Bug 87271f7cd6} -body { # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr WorkerSupport create A { superclass Worker method Work {var} { after 0 [info coroutine] yield lappend $var [my dump] } } # Copies the methods, changing the declarer # Test it works in the original source class with the copy around oo::copy A B B run 2 A run 2 } -cleanup { catch {rename dump {}} catch {A destroy} catch {B destroy} } -match glob -result {{* method Work class ::A *} {* method Work class ::A *}} WorkerBase destroy # Prove that the issue in [Bug 1865054] isn't an issue any more test oo-23.1 {Self-like derivation; complex case!} -setup { oo::class create SELF { superclass oo::class unexport create new # Next is just a convenience |
︙ | ︙ |
Changes to unix/tclAppInit.c.
︙ | ︙ | |||
25 26 27 28 29 30 31 | #ifdef TCL_TEST extern Tcl_LibraryInitProc Tcltest_Init; extern Tcl_LibraryInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #ifdef TCL_XT_TEST | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | #ifdef TCL_TEST extern Tcl_LibraryInitProc Tcltest_Init; extern Tcl_LibraryInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #ifdef TCL_XT_TEST extern void XtToolkitInitialize(void); extern Tcl_LibraryInitProc Tclxttest_Init; #endif /* TCL_XT_TEST */ /* * The following #if block allows you to change the AppInit function by using * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The * #if checks for that #define and uses Tcl_AppInit if it does not exist. |
︙ | ︙ |
Changes to unix/tclEpollNotfy.c.
︙ | ︙ | |||
38 39 40 41 42 43 44 | int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ LIST_ENTRY(FileHandler) readyNode; /* Next/previous in list of FileHandlers asso- * ciated with regular files (S_IFREG) that are * ready for I/O. */ struct PlatformEventData *pedPtr; /* Pointer to PlatformEventData associating this |
︙ | ︙ | |||
203 204 205 206 207 208 209 | if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) { newEvent.events |= EPOLLIN; } if (filePtr->mask & TCL_WRITABLE) { newEvent.events |= EPOLLOUT; } if (isNew) { | | | | | | | | | | | | | | | | | > | | | | 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 247 248 249 250 251 252 253 | if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) { newEvent.events |= EPOLLIN; } if (filePtr->mask & TCL_WRITABLE) { newEvent.events |= EPOLLOUT; } if (isNew) { newPedPtr = (struct PlatformEventData *) Tcl_Alloc(sizeof(struct PlatformEventData)); newPedPtr->filePtr = filePtr; newPedPtr->tsdPtr = tsdPtr; filePtr->pedPtr = newPedPtr; } newEvent.data.ptr = filePtr->pedPtr; /* * N.B. As discussed in Tcl_WaitForEvent(), epoll(7) does not support * regular files (S_IFREG). Therefore, filePtr is in these cases simply * added or deleted from the list of FileHandlers associated with regular * files belonging to tsdPtr. */ if (TclOSfstat(filePtr->fd, &fdStat) == -1) { Tcl_Panic("fstat: %s", strerror(errno)); } if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) { switch (errno) { case EPERM: switch (op) { case EPOLL_CTL_ADD: if (isNew) { LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr, filePtr, readyNode); } break; case EPOLL_CTL_DEL: LIST_REMOVE(filePtr, readyNode); break; } break; default: Tcl_Panic("epoll_ctl: %s", strerror(errno)); } } return; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
362 363 364 365 366 367 368 | tsdPtr->triggerFilePtr = filePtr; if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) { Tcl_Panic("epoll_create1: %s", strerror(errno)); } filePtr->mask = TCL_READABLE; PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1); if (!tsdPtr->readyEvents) { | | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 | tsdPtr->triggerFilePtr = filePtr; if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) { Tcl_Panic("epoll_create1: %s", strerror(errno)); } filePtr->mask = TCL_READABLE; PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1); if (!tsdPtr->readyEvents) { tsdPtr->maxReadyEvents = 512; tsdPtr->readyEvents = (struct epoll_event *) Tcl_Alloc( tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0])); } LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr); } /* |
︙ | ︙ | |||
508 509 510 511 512 513 514 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ | | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); int isNew = (filePtr == NULL); if (isNew) { filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); |
︙ | ︙ | |||
786 787 788 789 790 791 792 | *---------------------------------------------------------------------- */ int TclAsyncNotifier( int sigNumber, /* Signal number. */ Tcl_ThreadId threadId, /* Target thread. */ | | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 | *---------------------------------------------------------------------- */ int TclAsyncNotifier( int sigNumber, /* Signal number. */ Tcl_ThreadId threadId, /* Target thread. */ void *clientData, /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { #if TCL_THREADS /* * WARNING: * This code most likely runs in a signal handler. Thus, |
︙ | ︙ |
Changes to unix/tclKqueueNotfy.c.
︙ | ︙ | |||
36 37 38 39 40 41 42 | int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ LIST_ENTRY(FileHandler) readyNode; /* Next/previous in list of FileHandlers asso- * ciated with regular files (S_IFREG) that are * ready for I/O. */ struct PlatformEventData *pedPtr; /* Pointer to PlatformEventData associating this |
︙ | ︙ | |||
513 514 515 516 517 518 519 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ | | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); int isNew = (filePtr == NULL); if (isNew) { filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); |
︙ | ︙ | |||
782 783 784 785 786 787 788 | *---------------------------------------------------------------------- */ int TclAsyncNotifier( int sigNumber, /* Signal number. */ Tcl_ThreadId threadId, /* Target thread. */ | | | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 | *---------------------------------------------------------------------- */ int TclAsyncNotifier( int sigNumber, /* Signal number. */ Tcl_ThreadId threadId, /* Target thread. */ void *clientData, /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { #if TCL_THREADS /* * WARNING: * This code most likely runs in a signal handler. Thus, |
︙ | ︙ |
Changes to unix/tclLoadDyld.c.
︙ | ︙ | |||
144 145 146 147 148 149 150 | */ MODULE_SCOPE int TclpDlopen( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Obj *pathPtr, /* Name of the file containing the desired * code (UTF-8). */ | | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 | */ MODULE_SCOPE int TclpDlopen( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Obj *pathPtr, /* Name of the file containing the desired * code (UTF-8). */ Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ Tcl_FSUnloadFileProc **unloadProcPtr, /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ int flags) |
︙ | ︙ | |||
544 545 546 547 548 549 550 | Tcl_Interp *interp, /* Used for error reporting. */ void *buffer, /* Buffer containing the desired code * (allocated with TclpLoadMemoryGetBuffer). */ int size, /* Allocation size of buffer. */ int codeSize, /* Size of code data read into buffer or -1 if * an error occurred and the buffer should * just be freed. */ | | | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 | Tcl_Interp *interp, /* Used for error reporting. */ void *buffer, /* Buffer containing the desired code * (allocated with TclpLoadMemoryGetBuffer). */ int size, /* Allocation size of buffer. */ int codeSize, /* Size of code data read into buffer or -1 if * an error occurred and the buffer should * just be freed. */ Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ Tcl_FSUnloadFileProc **unloadProcPtr, /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ int flags) |
︙ | ︙ |
Changes to unix/tclLoadNext.c.
︙ | ︙ | |||
57 58 59 60 61 62 63 | Tcl_LoadHandle newHandle; struct mach_header *header; char *fileName; char *files[2]; const char *native; int result = 1; | | | | | 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 | Tcl_LoadHandle newHandle; struct mach_header *header; char *fileName; char *files[2]; const char *native; int result = 1; NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE); fileName = TclGetString(pathPtr); /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ native = Tcl_FSGetNativePath(pathPtr); files = {native,NULL}; result = rld_load(errorStream, &header, files, NULL); if (!result) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; if (Tcl_UtfToExternalDStringEx(interp, NULL, fileName, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; } native = Tcl_DStringValue(&ds); files = {native,NULL}; result = rld_load(errorStream, &header, files, NULL); Tcl_DStringFree(&ds); } if (!result) { char *data; int len, maxlen; |
︙ | ︙ |
Changes to unix/tclLoadOSF.c.
︙ | ︙ | |||
124 125 126 127 128 129 130 | * impossible to get a package name given a module. * * I build loadable modules with a makefile rule like * ld ... -export $@: -o $@ $(OBJS) */ if ((pkg = strrchr(fileName, '/')) == NULL) { | | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | * impossible to get a package name given a module. * * I build loadable modules with a makefile rule like * ld ... -export $@: -o $@ $(OBJS) */ if ((pkg = strrchr(fileName, '/')) == NULL) { pkg = fileName; } else { pkg++; } newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle)); newHandle->clientData = pkg; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; |
︙ | ︙ |
Changes to unix/tclSelectNotfy.c.
︙ | ︙ | |||
28 29 30 31 32 33 34 | int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; /* * The following structure contains a set of select() masks to track readable, * writable, and exception conditions. */ |
︙ | ︙ | |||
476 477 478 479 480 481 482 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ | | | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); if (filePtr == NULL) { filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); filePtr->fd = fd; |
︙ | ︙ | |||
917 918 919 920 921 922 923 | *---------------------------------------------------------------------- */ int TclAsyncNotifier( int sigNumber, /* Signal number. */ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */ | | | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 | *---------------------------------------------------------------------- */ int TclAsyncNotifier( int sigNumber, /* Signal number. */ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */ TCL_UNUSED(void *), /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { #if TCL_THREADS /* * WARNING: * This code most likely runs in a signal handler. Thus, |
︙ | ︙ |
Changes to unix/tclUnixChan.c.
︙ | ︙ | |||
26 27 28 29 30 31 32 | # endif /* HAVE_SYS_MODEM_H */ # ifdef FIONREAD # define GETREADQUEUE(fd, int) ioctl((fd), FIONREAD, &(int)) # elif defined(FIORDCHK) # define GETREADQUEUE(fd, int) int = ioctl((fd), FIORDCHK, NULL) # else | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | # endif /* HAVE_SYS_MODEM_H */ # ifdef FIONREAD # define GETREADQUEUE(fd, int) ioctl((fd), FIONREAD, &(int)) # elif defined(FIORDCHK) # define GETREADQUEUE(fd, int) int = ioctl((fd), FIORDCHK, NULL) # else # define GETREADQUEUE(fd, int) int = 0 # endif # ifdef TIOCOUTQ # define GETWRITEQUEUE(fd, int) ioctl((fd), TIOCOUTQ, &(int)) # else # define GETWRITEQUEUE(fd, int) int = 0 # endif |
︙ | ︙ | |||
158 159 160 161 162 163 164 | /* * This structure describes the channel type structure for file based IO: */ static const Tcl_ChannelType fileChannelType = { "file", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ | | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 | /* * This structure describes the channel type structure for file based IO: */ static const Tcl_ChannelType fileChannelType = { "file", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ NULL, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ NULL, NULL, /* Set option proc. */ FileGetOptionProc, /* Get option proc. */ FileWatchProc, /* Initialize notifier. */ FileGetHandleProc, /* Get OS handles out of channel. */ FileCloseProc, /* close2proc. */ FileBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ |
︙ | ︙ | |||
184 185 186 187 188 189 190 | * This structure describes the channel type structure for serial IO. * Note that this type is a subclass of the "file" type. */ static const Tcl_ChannelType ttyChannelType = { "tty", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ | | | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | * This structure describes the channel type structure for serial IO. * Note that this type is a subclass of the "file" type. */ static const Tcl_ChannelType ttyChannelType = { "tty", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ NULL, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ NULL, /* Seek proc. */ TtySetOptionProc, /* Set option proc. */ TtyGetOptionProc, /* Get option proc. */ FileWatchProc, /* Initialize notifier. */ FileGetHandleProc, /* Get OS handles out of channel. */ TtyCloseProc, /* close2proc. */ FileBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc. */ NULL, /* thread action proc. */ NULL /* truncate proc. */ }; |
︙ | ︙ | |||
221 222 223 224 225 226 227 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int FileBlockModeProc( | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int FileBlockModeProc( void *instanceData, /* File state. */ int mode) /* The mode to set. Can be TCL_MODE_BLOCKING * or TCL_MODE_NONBLOCKING. */ { FileState *fsPtr = (FileState *)instanceData; if (TclUnixSetBlockingMode(fsPtr->fd, mode) < 0) { return errno; |
︙ | ︙ | |||
254 255 256 257 258 259 260 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int FileInputProc( | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int FileInputProc( void *instanceData, /* File state. */ char *buf, /* Where to store data read. */ int toRead, /* How much space is available in the * buffer? */ int *errorCodePtr) /* Where to store error code. */ { FileState *fsPtr = (FileState *)instanceData; int bytesRead; /* How many bytes were actually read from the |
︙ | ︙ | |||
304 305 306 307 308 309 310 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int FileOutputProc( | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int FileOutputProc( void *instanceData, /* File state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ { FileState *fsPtr = (FileState *)instanceData; int written; |
︙ | ︙ | |||
351 352 353 354 355 356 357 | * Closes the device of the channel. * *---------------------------------------------------------------------- */ static int FileCloseProc( | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 | * Closes the device of the channel. * *---------------------------------------------------------------------- */ static int FileCloseProc( void *instanceData, /* File state. */ TCL_UNUSED(Tcl_Interp *), int flags) { FileState *fsPtr = (FileState *)instanceData; int errorCode = 0; if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { |
︙ | ︙ | |||
444 445 446 447 448 449 450 | * operations. * *---------------------------------------------------------------------- */ static long long FileWideSeekProc( | | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 | * operations. * *---------------------------------------------------------------------- */ static long long FileWideSeekProc( void *instanceData, /* File state. */ long long offset, /* Offset to seek to. */ int mode, /* Relative to where should we seek? Can be * one of SEEK_START, SEEK_CUR or SEEK_END. */ int *errorCodePtr) /* To store error code. */ { FileState *fsPtr = (FileState *)instanceData; long long newLoc; |
︙ | ︙ | |||
492 493 494 495 496 497 498 | { Tcl_Channel channel = (Tcl_Channel)clientData; Tcl_NotifyChannel(channel, mask); } static void FileWatchProc( | | | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 | { Tcl_Channel channel = (Tcl_Channel)clientData; Tcl_NotifyChannel(channel, mask); } static void FileWatchProc( void *instanceData, /* The file state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { FileState *fsPtr = (FileState *)instanceData; /* |
︙ | ︙ | |||
532 533 534 535 536 537 538 | * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc( | | | | 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 | * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc( void *instanceData, /* The file state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ void **handlePtr) /* Where to store the handle. */ { FileState *fsPtr = (FileState *)instanceData; if (direction & fsPtr->validMask) { *handlePtr = INT2PTR(fsPtr->fd); return TCL_OK; } |
︙ | ︙ | |||
769 770 771 772 773 774 775 | * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtySetOptionProc( | | | 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 | * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtySetOptionProc( void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ { TtyState *fsPtr = (TtyState *)instanceData; size_t len, vlen; TtyAttrs tty; |
︙ | ︙ | |||
1109 1110 1111 1112 1113 1114 1115 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtyGetOptionProc( | | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtyGetOptionProc( void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ { TtyState *fsPtr = (TtyState *)instanceData; size_t len; char buf[3*TCL_INTEGER_SPACE + 16]; |
︙ | ︙ | |||
1650 1651 1652 1653 1654 1655 1656 | * We cannot if/else/endif the strchr arguments, it has to be the whole * function. On AIX this function is apparently a macro, and macros do * not allow preprocessor directives in their arguments. */ if ( #if defined(PAREXT) | | | | | 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 | * We cannot if/else/endif the strchr arguments, it has to be the whole * function. On AIX this function is apparently a macro, and macros do * not allow preprocessor directives in their arguments. */ if ( #if defined(PAREXT) strchr("noems", parity) #else strchr("noe", parity) #endif /* PAREXT */ == NULL) { if (interp != NULL) { TclPrintfResult(interp, "%s parity: should be %s", bad, #if defined(PAREXT) "n, o, e, m, or s" #else "n, o, or e" |
︙ | ︙ | |||
2065 2066 2067 2068 2069 2070 2071 | const char *chanID, /* String that identifies file. */ int forWriting, /* 1 means the file is going to be used for * writing, 0 means for reading. */ TCL_UNUSED(int), /* Obsolete argument. * Ignored, we always check that * the channel is open for the requested * mode. */ | | | 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 | const char *chanID, /* String that identifies file. */ int forWriting, /* 1 means the file is going to be used for * writing, 0 means for reading. */ TCL_UNUSED(int), /* Obsolete argument. * Ignored, we always check that * the channel is open for the requested * mode. */ void **filePtr) /* Store pointer to FILE structure here. */ { Tcl_Channel chan; int chanMode, fd; const Tcl_ChannelType *chanTypePtr; void *data; FILE *f; |
︙ | ︙ |
Changes to unix/tclUnixCompat.c.
︙ | ︙ | |||
160 161 162 163 164 165 166 | } /* *--------------------------------------------------------------------------- * * TclpGetPwNam -- * | | | | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | } /* *--------------------------------------------------------------------------- * * TclpGetPwNam -- * * Thread-safe wrappers for getpwnam(). See "man getpwnam" for more * details. * * Results: * Pointer to struct passwd on success or NULL on error. * * Side effects: * None. * *--------------------------------------------------------------------------- */ struct passwd * TclpGetPwNam( const char *name) |
︙ | ︙ | |||
240 241 242 243 244 245 246 | } /* *--------------------------------------------------------------------------- * * TclpGetPwUid -- * | | | | | | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | } /* *--------------------------------------------------------------------------- * * TclpGetPwUid -- * * Thread-safe wrappers for getpwuid(). See "man getpwuid" for more * details. * * Results: * Pointer to struct passwd on success or NULL on error. * * Side effects: * None. * *--------------------------------------------------------------------------- */ struct passwd * TclpGetPwUid( uid_t uid) |
︙ | ︙ | |||
343 344 345 346 347 348 349 | #endif /* NEED_PW_CLEANER */ /* *--------------------------------------------------------------------------- * * TclpGetGrNam -- * | | | | | | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 | #endif /* NEED_PW_CLEANER */ /* *--------------------------------------------------------------------------- * * TclpGetGrNam -- * * Thread-safe wrappers for getgrnam(). See "man getgrnam" for more * details. * * Results: * Pointer to struct group on success or NULL on error. * * Side effects: * None. * *--------------------------------------------------------------------------- */ struct group * TclpGetGrNam( const char *name) |
︙ | ︙ | |||
423 424 425 426 427 428 429 | } /* *--------------------------------------------------------------------------- * * TclpGetGrGid -- * | | | | | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 | } /* *--------------------------------------------------------------------------- * * TclpGetGrGid -- * * Thread-safe wrappers for getgrgid(). See "man getgrgid" for more * details. * * Results: * Pointer to struct group on success or NULL on error. * * Side effects: * None. * *--------------------------------------------------------------------------- */ struct group * TclpGetGrGid( gid_t gid) |
︙ | ︙ | |||
526 527 528 529 530 531 532 | #endif /* NEED_GR_CLEANER */ /* *--------------------------------------------------------------------------- * * TclpGetHostByName -- * | | | | | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 | #endif /* NEED_GR_CLEANER */ /* *--------------------------------------------------------------------------- * * TclpGetHostByName -- * * Thread-safe wrappers for gethostbyname(). See "man gethostbyname" for * more details. * * Results: * Pointer to struct hostent on success or NULL on error. * * Side effects: * None. * *--------------------------------------------------------------------------- */ struct hostent * TclpGetHostByName( const char *name) |
︙ | ︙ | |||
594 595 596 597 598 599 600 | } /* *--------------------------------------------------------------------------- * * TclpGetHostByAddr -- * | | | | | | 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 | } /* *--------------------------------------------------------------------------- * * TclpGetHostByAddr -- * * Thread-safe wrappers for gethostbyaddr(). See "man gethostbyaddr" for * more details. * * Results: * Pointer to struct hostent on success or NULL on error. * * Side effects: * None. * *--------------------------------------------------------------------------- */ struct hostent * TclpGetHostByAddr( const char *addr, |
︙ | ︙ | |||
657 658 659 660 661 662 663 | } /* *--------------------------------------------------------------------------- * * CopyGrp -- * | | | | | | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 | } /* *--------------------------------------------------------------------------- * * CopyGrp -- * * Copies string fields of the group structure to the private buffer, * honouring the size of the buffer. * * Results: * 0 on success or -1 on error (errno = ERANGE). * * Side effects: * None. * *--------------------------------------------------------------------------- */ #ifdef NEED_COPYGRP #define NEED_COPYARRAY 1 #define NEED_COPYSTRING 1 |
︙ | ︙ | |||
730 731 732 733 734 735 736 | #endif /* NEED_COPYGRP */ /* *--------------------------------------------------------------------------- * * CopyHostent -- * | | | | | | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 | #endif /* NEED_COPYGRP */ /* *--------------------------------------------------------------------------- * * CopyHostent -- * * Copies string fields of the hostent structure to the private buffer, * honouring the size of the buffer. * * Results: * Number of bytes copied on success or -1 on error (errno = ERANGE) * * Side effects: * None * *--------------------------------------------------------------------------- */ #ifdef NEED_COPYHOSTENT #define NEED_COPYSTRING 1 #define NEED_COPYARRAY 1 |
︙ | ︙ | |||
792 793 794 795 796 797 798 | #endif /* NEED_COPYHOSTENT */ /* *--------------------------------------------------------------------------- * * CopyPwd -- * | | | | | | | 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 | #endif /* NEED_COPYHOSTENT */ /* *--------------------------------------------------------------------------- * * CopyPwd -- * * Copies string fields of the passwd structure to the private buffer, * honouring the size of the buffer. * * Results: * 0 on success or -1 on error (errno = ERANGE). * * Side effects: * We are not copying the gecos field as it may not be supported on all * platforms. * *--------------------------------------------------------------------------- */ #ifdef NEED_COPYPWD #define NEED_COPYSTRING 1 |
︙ | ︙ | |||
858 859 860 861 862 863 864 | #endif /* NEED_COPYPWD */ /* *--------------------------------------------------------------------------- * * CopyArray -- * | | | | | | 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 | #endif /* NEED_COPYPWD */ /* *--------------------------------------------------------------------------- * * CopyArray -- * * Copies array of NULL-terminated or fixed-length strings to the private * buffer, honouring the size of the buffer. * * Results: * Number of bytes copied on success or -1 on error (errno = ERANGE) * * Side effects: * None. * *--------------------------------------------------------------------------- */ #ifdef NEED_COPYARRAY static int CopyArray( |
︙ | ︙ | |||
922 923 924 925 926 927 928 | #endif /* NEED_COPYARRAY */ /* *--------------------------------------------------------------------------- * * CopyString -- * | | | | | | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 | #endif /* NEED_COPYARRAY */ /* *--------------------------------------------------------------------------- * * CopyString -- * * Copies a NULL-terminated string to the private buffer, honouring the * size of the buffer * * Results: * 0 success or -1 on error (errno = ERANGE) * * Side effects: * None * *--------------------------------------------------------------------------- */ #ifdef NEED_COPYSTRING static int CopyString( |
︙ | ︙ | |||
982 983 984 985 986 987 988 | * instruction in the four integers designated by 'regsPtr' * *---------------------------------------------------------------------- */ int TclWinCPUID( | | | < | | | | | < | | | | | | 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 | * instruction in the four integers designated by 'regsPtr' * *---------------------------------------------------------------------- */ int TclWinCPUID( int index, /* Which CPUID value to retrieve. */ int *regsPtr) /* Registers after the CPUID. */ { int status = TCL_ERROR; /* See: <http://en.wikipedia.org/wiki/CPUID> */ #if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64) __asm__ __volatile__("movq %%rbx, %%rsi \n\t" /* save %rbx */ "cpuid \n\t" "xchgq %%rsi, %%rbx \n\t" /* restore the old %rbx */ : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) : "a"(index)); status = TCL_OK; #elif defined(__i386__) || defined(_M_IX86) __asm__ __volatile__("mov %%ebx, %%esi \n\t" /* save %ebx */ "cpuid \n\t" "xchg %%esi, %%ebx \n\t" /* restore the old %ebx */ : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) : "a"(index)); status = TCL_OK; #else (void)index; (void)regsPtr; #endif return status; } |
︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * Portions of this code were derived from NetBSD source code which has the * following copyright notice: * * Copyright © 1988, 1993, 1994 | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * Portions of this code were derived from NetBSD source code which has the * following copyright notice: * * Copyright © 1988, 1993, 1994 * The Regents of the University of California. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * 1. Redistributions of source code must retain the above copyright notice, * this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the |
︙ | ︙ | |||
753 754 755 756 757 758 759 | Tcl_Obj **errorPtr) { Tcl_DString ds; Tcl_DString srcString, dstString; int ret; Tcl_Obj *transPtr; | | | | 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 | Tcl_Obj **errorPtr) { Tcl_DString ds; Tcl_DString srcString, dstString; int ret; Tcl_Obj *transPtr; transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr); ret = Tcl_UtfToExternalDStringEx(NULL, NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), -1, 0, &srcString, NULL); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } if (ret != TCL_OK) { *errorPtr = srcPathPtr; } else { transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr); ret = Tcl_UtfToExternalDStringEx(NULL, NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), -1, TCL_ENCODING_PROFILE_TCL8, &dstString, NULL); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } if (ret != TCL_OK) { |
︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 | * *--------------------------------------------------------------------------- */ static int CopyFileAtts( #ifdef MAC_OSX_TCL | | | 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 | * *--------------------------------------------------------------------------- */ static int CopyFileAtts( #ifdef MAC_OSX_TCL const char *src, /* Path name of source file (native). */ #else TCL_UNUSED(const char *) /*src*/, #endif const char *dst, /* Path name of target file (native). */ const Tcl_StatBuf *statBufPtr) /* Stat info for source file */ { |
︙ | ︙ | |||
1759 1760 1761 1762 1763 1764 1765 | * *---------------------------------------------------------------------- */ static int GetModeFromPermString( TCL_UNUSED(Tcl_Interp *), | | | | 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 | * *---------------------------------------------------------------------- */ static int GetModeFromPermString( TCL_UNUSED(Tcl_Interp *), const char *modeStringPtr, /* Permissions string */ mode_t *modePtr) /* pointer to the mode value */ { mode_t newMode; mode_t oldMode; /* Storage for the value of the old mode (that * is passed in), to allow for the chmod style * manipulation. */ int i,n, who, op, what, op_found, who_found; /* * We start off checking for an "rwxrwxrwx" style permissions string */ if (strlen(modeStringPtr) != 9) { goto chmodStyleCheck; |
︙ | ︙ | |||
2068 2069 2070 2071 2072 2073 2074 | * 'Realpath' transforms an empty string into the normalized pwd, * which is the wrong answer. */ return 0; } | | | 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 | * 'Realpath' transforms an empty string into the normalized pwd, * which is the wrong answer. */ return 0; } if (Tcl_UtfToExternalDStringEx(interp, NULL, path,nextCheckpoint, 0, &ds, NULL)) { Tcl_DStringFree(&ds); return -1; } nativePath = Tcl_DStringValue(&ds); if (Realpath(nativePath, normPath) != NULL) { Tcl_Size newNormLen; |
︙ | ︙ | |||
2481 2482 2483 2484 2485 2486 2487 | * The readonly attribute of the file is changed. * *--------------------------------------------------------------------------- */ static int SetUnixFileAttributes( | | | | | | 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 | * The readonly attribute of the file is changed. * *--------------------------------------------------------------------------- */ static int SetUnixFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr) /* The attribute to set. */ { int yesNo, fileAttributes, old; WCHAR *winPath; if (Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ |
Changes to unix/tclUnixFile.c.
︙ | ︙ | |||
151 152 153 154 155 156 157 | #ifdef DJGPP if (name[1] == ':') #else if (name[0] == '/') #endif { encoding = Tcl_GetEncoding(NULL, NULL); | | < | < | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 | #ifdef DJGPP if (name[1] == ':') #else if (name[0] == '/') #endif { encoding = Tcl_GetEncoding(NULL, NULL); Tcl_ExternalToUtfDStringEx(NULL, encoding, name, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &utfName, NULL); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding); Tcl_DStringFree(&utfName); goto done; } if (TclpGetCwd(NULL, &cwd) == NULL) { TclNewObj(obj); TclSetObjNameOfExecutable(obj, NULL); |
︙ | ︙ | |||
190 191 192 193 194 195 196 | TclDStringAppendLiteral(&buffer, "/"); } Tcl_DStringFree(&cwd); TclDStringAppendDString(&buffer, &nameString); Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); | | | | < | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 | TclDStringAppendLiteral(&buffer, "/"); } Tcl_DStringFree(&cwd); TclDStringAppendDString(&buffer, &nameString); Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); Tcl_ExternalToUtfDStringEx(NULL, encoding, Tcl_DStringValue(&buffer), TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &utfName, NULL); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding); Tcl_DStringFree(&utfName); done: Tcl_DStringFree(&buffer); } #endif |
︙ | ︙ | |||
307 308 309 310 311 312 313 | } } /* * Now open the directory for reading and iterate over the contents. */ | | < | | 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 | } } /* * Now open the directory for reading and iterate over the contents. */ if (Tcl_UtfToExternalDStringEx(interp, NULL, dirName, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { Tcl_DStringFree(&dsOrig); Tcl_DStringFree(&ds); Tcl_DecrRefCount(fileNamePtr); return TCL_ERROR; } native = Tcl_DStringValue(&ds); if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */ || !S_ISDIR(statBuf.st_mode)) { Tcl_DStringFree(&dsOrig); Tcl_DStringFree(&ds); Tcl_DecrRefCount(fileNamePtr); return TCL_OK; } d = TclOSopendir(native); /* INTL: Native. */ if (d == NULL) { Tcl_DStringFree(&ds); if (interp != NULL) { TclPrintfResult(interp, "couldn't read directory \"%s\": %s", Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)); } Tcl_DStringFree(&dsOrig); |
︙ | ︙ | |||
377 378 379 380 381 382 383 | } /* * Now check to see if the file matches, according to both type * and pattern. If so, add the file to the result. */ | | | | < | 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 | } /* * Now check to see if the file matches, according to both type * and pattern. If so, add the file to the result. */ if (Tcl_ExternalToUtfDStringEx(interp, NULL, entryPtr->d_name, TCL_INDEX_NONE, 0, &utfDs, NULL) != TCL_OK) { matchResult = -1; break; } utfname = Tcl_DStringValue(&utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; if (types != NULL) { Tcl_DStringSetLength(&ds, nativeDirLen); native = Tcl_DStringAppend(&ds, entryPtr->d_name, TCL_INDEX_NONE); matchResult = NativeMatchType(interp, native, entryPtr->d_name, types); typeOk = (matchResult == 1); } if (typeOk) { Tcl_ListObjAppendElement(interp, resultPtr, TclNewFSPathObj(pathPtr, utfname, |
︙ | ︙ | |||
438 439 440 441 442 443 444 | * None. * *---------------------------------------------------------------------- */ static int NativeMatchType( | | | | | | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 | * None. * *---------------------------------------------------------------------- */ static int NativeMatchType( Tcl_Interp *interp, /* Interpreter to receive errors. */ const char *nativeEntry, /* Native path to check. */ const char *nativeName, /* Native filename to check. */ Tcl_GlobTypeData *types) /* Type description to match against. */ { Tcl_StatBuf buf; if (types == NULL) { /* * Simply check for the file's existence, but do it with lstat, in * case it is a link to a file which doesn't exist (since that case |
︙ | ︙ | |||
611 612 613 614 615 616 617 | Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with * name of user's home directory. */ { struct passwd *pwPtr; Tcl_DString ds; const char *native; | | < | < | 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 | Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with * name of user's home directory. */ { struct passwd *pwPtr; Tcl_DString ds; const char *native; if (Tcl_UtfToExternalDStringEx(NULL, NULL, name, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { Tcl_DStringFree(&ds); return NULL; } native = Tcl_DStringValue(&ds); pwPtr = TclpGetPwNam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); if (pwPtr == NULL) { return NULL; } if (Tcl_ExternalToUtfDStringEx(NULL, NULL, pwPtr->pw_dir, TCL_INDEX_NONE, 0, bufferPtr, NULL) != TCL_OK) { return NULL; } else { return Tcl_DStringValue(bufferPtr); } } /* |
︙ | ︙ | |||
807 808 809 810 811 812 813 | if (interp != NULL) { TclPrintfResult(interp, "error getting working directory name: %s", Tcl_PosixError(interp)); } return NULL; } | | < | 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 | if (interp != NULL) { TclPrintfResult(interp, "error getting working directory name: %s", Tcl_PosixError(interp)); } return NULL; } if (Tcl_ExternalToUtfDStringEx(interp, NULL, buffer, TCL_INDEX_NONE, 0, bufferPtr, NULL) != TCL_OK) { return NULL; } return Tcl_DStringValue(bufferPtr); } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
846 847 848 849 850 851 852 | { #ifndef DJGPP char link[MAXPATHLEN]; Tcl_Size length; const char *native; Tcl_DString ds; | | < | < | 838 839 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 | { #ifndef DJGPP char link[MAXPATHLEN]; Tcl_Size length; const char *native; Tcl_DString ds; if (Tcl_UtfToExternalDStringEx(NULL, NULL, path, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { Tcl_DStringFree(&ds); return NULL; } native = Tcl_DStringValue(&ds); length = readlink(native, link, sizeof(link)); /* INTL: Native. */ Tcl_DStringFree(&ds); if (length < 0) { return NULL; } if (Tcl_ExternalToUtfDStringEx(NULL, NULL, link, length, 0, linkPtr, NULL) == TCL_OK) { return Tcl_DStringValue(linkPtr); } #endif /* !DJGPP */ return NULL; } |
︙ | ︙ | |||
995 996 997 998 999 1000 1001 | */ transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr); if (transPtr == NULL) { return NULL; } target = TclGetStringFromObj(transPtr, &length); | | < | 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 | */ transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr); if (transPtr == NULL) { return NULL; } target = TclGetStringFromObj(transPtr, &length); if (Tcl_UtfToExternalDStringEx(NULL, NULL, target, length, 0, &ds, NULL) != TCL_OK) { Tcl_DStringFree(&ds); return NULL; } target = Tcl_DStringValue(&ds); Tcl_DecrRefCount(transPtr); if (symlink(target, src) != 0) { |
︙ | ︙ | |||
1030 1031 1032 1033 1034 1035 1036 | transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); if (transPtr == NULL) { return NULL; } Tcl_DecrRefCount(transPtr); | | < | < | 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 | transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); if (transPtr == NULL) { return NULL; } Tcl_DecrRefCount(transPtr); length = readlink((const char *)Tcl_FSGetNativePath(pathPtr), link, sizeof(link)); if (length < 0) { return NULL; } if (Tcl_ExternalToUtfDStringEx(NULL, NULL, link, (size_t)length, 0, &ds, NULL) != TCL_OK) { return NULL; } linkPtr = Tcl_DStringToObj(&ds); Tcl_IncrRefCount(linkPtr); return linkPtr; } } |
︙ | ︙ | |||
1104 1105 1106 1107 1108 1109 1110 | Tcl_Obj * TclpNativeToNormalized( void *clientData) { Tcl_DString ds; | | < | 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 | Tcl_Obj * TclpNativeToNormalized( void *clientData) { Tcl_DString ds; Tcl_ExternalToUtfDStringEx(NULL, NULL, (const char *) clientData, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); return Tcl_DStringToObj(&ds); } /* *--------------------------------------------------------------------------- * * TclNativeCreateNativeRep -- |
︙ | ︙ |
Changes to unix/tclUnixInit.c.
︙ | ︙ | |||
50 51 52 53 54 55 56 | static const char *const processors[NUMPROCESSORS] = { "i686", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "x86_64", "ia32_on_win64", "neutral", "arm64", "arm32_on_win64", "ia32_on_arm64" }; typedef struct { union { | | | | | | | | | | | | | 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 76 77 78 | static const char *const processors[NUMPROCESSORS] = { "i686", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "x86_64", "ia32_on_win64", "neutral", "arm64", "arm32_on_win64", "ia32_on_arm64" }; typedef struct { union { unsigned int dwOemId; struct { int wProcessorArchitecture; int wReserved; }; }; unsigned int dwPageSize; void *lpMinimumApplicationAddress; void *lpMaximumApplicationAddress; void *dwActiveProcessorMask; unsigned int dwNumberOfProcessors; unsigned int dwProcessorType; unsigned int dwAllocationGranularity; int wProcessorLevel; int wProcessorRevision; } SYSTEM_INFO; typedef struct { unsigned int dwOSVersionInfoSize; unsigned int dwMajorVersion; unsigned int dwMinorVersion; unsigned int dwBuildNumber; |
︙ | ︙ | |||
848 849 850 851 852 853 854 | CFRelease(frameworksURL); } } } #endif /* HAVE_COREFOUNDATION */ p = pkgPath; while ((q = strchr(p, ':')) != NULL) { | | | | < | | | | | | | < | | 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 | CFRelease(frameworksURL); } } } #endif /* HAVE_COREFOUNDATION */ p = pkgPath; while ((q = strchr(p, ':')) != NULL) { Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, q-p)); p = q+1; } if (*p) { Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, -1)); } Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_pkgPath", -1), NULL, pkgListObj, TCL_GLOBAL_ONLY); { /* Some platforms build configure scripts expect ~ expansion so do that */ Tcl_Obj *origPaths; Tcl_Obj *resolvedPaths; origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY); resolvedPaths = TclResolveTildePathList(origPaths); if (resolvedPaths != origPaths && resolvedPaths != NULL) { Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, resolvedPaths, TCL_GLOBAL_ONLY); } } #ifdef DJGPP Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY); #else Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); #endif |
︙ | ︙ | |||
895 896 897 898 899 900 901 | GetSystemInfo(&sysInfo); if (osInfo.dwMajorVersion == 10 && osInfo.dwBuildNumber >= 22000) { osInfo.dwMajorVersion = 11; } Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY); | | < | 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 | GetSystemInfo(&sysInfo); if (osInfo.dwMajorVersion == 10 && osInfo.dwBuildNumber >= 22000) { osInfo.dwMajorVersion = 11; } Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY); snprintf(buffer, sizeof(buffer), "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); if (sysInfo.wProcessorArchitecture < NUMPROCESSORS) { Tcl_SetVar2(interp, "tcl_platform", "machine", processors[sysInfo.wProcessorArchitecture], TCL_GLOBAL_ONLY); } |
︙ | ︙ | |||
986 987 988 989 990 991 992 | Tcl_DStringFree(&ds); } /* * Define what the platform PATH separator is. [TIP #315] */ | | | 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 | Tcl_DStringFree(&ds); } /* * Define what the platform PATH separator is. [TIP #315] */ Tcl_SetVar2(interp, "tcl_platform","pathSeparator", ":", TCL_GLOBAL_ONLY); } /* *---------------------------------------------------------------------- * * TclpFindVariable -- * |
︙ | ︙ |
Changes to unix/tclUnixPipe.c.
︙ | ︙ | |||
76 77 78 79 80 81 82 | * This structure describes the channel type structure for command pipe based * I/O: */ static const Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | * This structure describes the channel type structure for command pipe based * I/O: */ static const Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ NULL, /* Close proc. */ PipeInputProc, /* Input proc. */ PipeOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ PipeWatchProc, /* Initialize notifier. */ PipeGetHandleProc, /* Get OS handles out of channel. */ |
︙ | ︙ | |||
351 352 353 354 355 356 357 | * The file is closed. * *---------------------------------------------------------------------- */ int TclpCloseFile( | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 | * The file is closed. * *---------------------------------------------------------------------- */ int TclpCloseFile( TclFile file) /* The file to close. */ { int fd = GetFd(file); /* * Refuse to close the fds for stdin, stdout and stderr. */ |
︙ | ︙ | |||
396 397 398 399 400 401 402 | int TclpCreateProcess( Tcl_Interp *interp, /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ | | | 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 | int TclpCreateProcess( Tcl_Interp *interp, /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ size_t argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName * call). Additional arguments have not been * converted. */ TclFile inputFile, /* If non-NULL, gives the file to use as input * for the child process. If inputFile file is |
︙ | ︙ | |||
567 568 569 570 571 572 573 | * Set up stdio file handles for the child process. */ if (!SetupStdFile(inputFile, TCL_STDIN) || !SetupStdFile(outputFile, TCL_STDOUT) || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) || (joinThisError && | | | 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 | * Set up stdio file handles for the child process. */ if (!SetupStdFile(inputFile, TCL_STDIN) || !SetupStdFile(outputFile, TCL_STDOUT) || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) || (joinThisError && ((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) { snprintf(errSpace, sizeof(errSpace), "%dforked process couldn't set up input/output", errno); len = strlen(errSpace); if (len != (size_t) write(fd, errSpace, len)) { Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut"); } _exit(1); |
︙ | ︙ | |||
997 998 999 1000 1001 1002 1003 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int PipeBlockModeProc( | | | 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int PipeBlockModeProc( void *instanceData, /* Pipe state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { PipeState *psPtr = (PipeState *)instanceData; if (psPtr->inFile |
︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 | * Closes the command pipeline channel. * *---------------------------------------------------------------------- */ static int PipeClose2Proc( | | | 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 | * Closes the command pipeline channel. * *---------------------------------------------------------------------- */ static int PipeClose2Proc( void *instanceData, /* The pipe to close. */ Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { PipeState *pipePtr = (PipeState *)instanceData; Tcl_Channel errChan; int errorCode, result; |
︙ | ︙ | |||
1134 1135 1136 1137 1138 1139 1140 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int PipeInputProc( | | | 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int PipeInputProc( void *instanceData, /* Pipe state. */ char *buf, /* Where to store data read. */ int toRead, /* How much space is available in the * buffer? */ int *errorCodePtr) /* Where to store error code. */ { PipeState *psPtr = (PipeState *)instanceData; int bytesRead; /* How many bytes were actually read from the |
︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc( | | | 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc( void *instanceData, /* Pipe state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ { PipeState *psPtr = (PipeState *)instanceData; int written; |
︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 | { Tcl_Channel channel = (Tcl_Channel)clientData; Tcl_NotifyChannel(channel, mask); } static void PipeWatchProc( | | | 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 | { Tcl_Channel channel = (Tcl_Channel)clientData; Tcl_NotifyChannel(channel, mask); } static void PipeWatchProc( void *instanceData, /* The pipe state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { PipeState *psPtr = (PipeState *)instanceData; int newmask; |
︙ | ︙ | |||
1292 1293 1294 1295 1296 1297 1298 | * None. * *---------------------------------------------------------------------- */ static int PipeGetHandleProc( | | | | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 | * None. * *---------------------------------------------------------------------- */ static int PipeGetHandleProc( void *instanceData, /* The pipe state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ void **handlePtr) /* Where to store the handle. */ { PipeState *psPtr = (PipeState *)instanceData; if (direction == TCL_READABLE && psPtr->inFile) { *handlePtr = INT2PTR(GetFd(psPtr->inFile)); return TCL_OK; } |
︙ | ︙ |
Changes to unix/tclUnixPort.h.
︙ | ︙ | |||
232 233 234 235 236 237 238 | #ifndef WEXITSTATUS # define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) \ | | | 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 | #ifndef WEXITSTATUS # define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) \ (((*((int *) &(stat)))) && ((*((int *) &(stat))) \ == ((*((int *) &(stat))) & 0x00FF))) #endif #ifndef WTERMSIG # define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7F) #endif |
︙ | ︙ |
Changes to unix/tclUnixSock.c.
︙ | ︙ | |||
19 20 21 22 23 24 25 | */ #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) #define GOT_BITS(var, bits) (((var) & (bits)) != 0) /* "sock" + a pointer in hex + \0 */ | | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | */ #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) #define GOT_BITS(var, bits) (((var) & (bits)) != 0) /* "sock" + a pointer in hex + \0 */ #define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) #define SOCK_TEMPLATE "sock%" TCL_Z_MODIFIER "x" #undef SOCKET /* Possible conflict with win32 SOCKET */ /* * This is needed to comply with the strict aliasing rules of GCC, but it also * simplifies casting between the different sockaddr types. */ |
︙ | ︙ | |||
60 61 62 63 64 65 66 | int interest; /* Event types of interest */ /* * Only needed for server sockets */ Tcl_TcpAcceptProc *acceptProc; | | | | | | | | 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 | int interest; /* Event types of interest */ /* * Only needed for server sockets */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ void *acceptProcData; /* The data for the accept proc. */ /* * Only needed for client sockets */ struct addrinfo *addrlist; /* Addresses to connect to. */ struct addrinfo *addr; /* Iterator over addrlist. */ struct addrinfo *myaddrlist;/* Local address. */ struct addrinfo *myaddr; /* Iterator over myaddrlist. */ int filehandlers; /* Caches FileHandlers that get set up while * an async socket is not yet connected. */ int connectError; /* Cache SO_ERROR of async socket. */ int cachedBlocking; /* Cache blocking mode of async socket. */ }; /* * These bits may be OR'ed together into the "flags" field of a TcpState * structure. */ |
︙ | ︙ | |||
152 153 154 155 156 157 158 | * This structure describes the channel type structure for TCP socket * based IO: */ static const Tcl_ChannelType tcpChannelType = { "tcp", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | * This structure describes the channel type structure for TCP socket * based IO: */ static const Tcl_ChannelType tcpChannelType = { "tcp", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ NULL, /* Close proc. */ TcpInputProc, /* Input proc. */ TcpOutputProc, /* Output proc. */ NULL, /* Seek proc. */ TcpSetOptionProc, /* Set option proc. */ TcpGetOptionProc, /* Get option proc. */ TcpWatchProc, /* Initialize notifier. */ TcpGetHandleProc, /* Get OS handles out of channel. */ |
︙ | ︙ | |||
191 192 193 194 195 196 197 | char host[NI_MAXHOST], port[NI_MAXSERV]; struct addrinfo *ai; for (ai = addrlist; ai != NULL; ai = ai->ai_next) { getnameinfo(ai->ai_addr, ai->ai_addrlen, host, sizeof(host), port, sizeof(port), NI_NUMERICHOST|NI_NUMERICSERV); | | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 | char host[NI_MAXHOST], port[NI_MAXSERV]; struct addrinfo *ai; for (ai = addrlist; ai != NULL; ai = ai->ai_next) { getnameinfo(ai->ai_addr, ai->ai_addrlen, host, sizeof(host), port, sizeof(port), NI_NUMERICHOST|NI_NUMERICSERV); fprintf(stderr,"%s: %s:%s\n", prefix, host, port); } } #endif /* * ---------------------------------------------------------------------- * * InitializeHostName -- |
︙ | ︙ | |||
223 224 225 226 227 228 229 | #ifndef NO_UNAME struct utsname u; struct hostent *hp; memset(&u, (int) 0, sizeof(struct utsname)); if (uname(&u) >= 0) { /* INTL: Native. */ | | | | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 | #ifndef NO_UNAME struct utsname u; struct hostent *hp; memset(&u, (int) 0, sizeof(struct utsname)); if (uname(&u) >= 0) { /* INTL: Native. */ hp = TclpGetHostByName(u.nodename); /* INTL: Native. */ if (hp == NULL) { /* * Sometimes the nodename is fully qualified, but gets truncated * as it exceeds SYS_NMLN. See if we can just get the immediate * nodename and get a proper answer that way. */ char *dot = strchr(u.nodename, '.'); if (dot != NULL) { char *node = (char *)Tcl_Alloc(dot - u.nodename + 1); memcpy(node, u.nodename, dot - u.nodename); node[dot - u.nodename] = '\0'; hp = TclpGetHostByName(node); Tcl_Free(node); } } if (hp != NULL) { native = hp->h_name; } else { native = u.nodename; } } #else /* !NO_UNAME */ /* * Uname doesn't exist; try gethostname instead. * * There is no portable macro for the maximum length of host names * returned by gethostbyname(). We should only trust SYS_NMLN if it is at |
︙ | ︙ | |||
353 354 355 356 357 358 359 | * Sets the device into blocking or nonblocking mode. * * ---------------------------------------------------------------------- */ static int TcpBlockModeProc( | | | | | 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 | * Sets the device into blocking or nonblocking mode. * * ---------------------------------------------------------------------- */ static int TcpBlockModeProc( void *instanceData, /* Socket state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { TcpState *statePtr = (TcpState *)instanceData; if (mode == TCL_MODE_BLOCKING) { CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING); } else { SET_BITS(statePtr->flags, TCP_NONBLOCKING); } if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { statePtr->cachedBlocking = mode; return 0; } if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) { return errno; } return 0; } |
︙ | ︙ | |||
439 440 441 442 443 444 445 | * In socket test mode do not continue with the connect. * Exceptions are: * - Call by recv/send and blocking socket * (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING)) */ if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE) | | | | | | | | | | | | | | | | | | | | | 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 | * In socket test mode do not continue with the connect. * Exceptions are: * - Call by recv/send and blocking socket * (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING)) */ if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE) && !(errorCodePtr != NULL && !GOT_BITS(statePtr->flags, TCP_NONBLOCKING))) { *errorCodePtr = EWOULDBLOCK; return -1; } if (errorCodePtr == NULL || GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { timeout = 0; } else { timeout = -1; } do { if (TclUnixWaitForFile(statePtr->fds.fd, TCL_WRITABLE | TCL_EXCEPTION, timeout) != 0) { TcpConnect(NULL, statePtr); } /* * Do this only once in the nonblocking case and repeat it until the * socket is final when blocking. */ } while (timeout == -1 && GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)); if (errorCodePtr != NULL) { if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { *errorCodePtr = EAGAIN; return -1; } else if (statePtr->connectError != 0) { *errorCodePtr = ENOTCONN; return -1; } } return 0; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
498 499 500 501 502 503 504 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int TcpInputProc( | | | 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int TcpInputProc( void *instanceData, /* Socket state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ int *errorCodePtr) /* Where to store error code. */ { TcpState *statePtr = (TcpState *)instanceData; int bytesRead; |
︙ | ︙ | |||
549 550 551 552 553 554 555 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int TcpOutputProc( | | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int TcpOutputProc( void *instanceData, /* Socket state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ { TcpState *statePtr = (TcpState *)instanceData; int written; |
︙ | ︙ | |||
590 591 592 593 594 595 596 | * Closes the socket of the channel. * *---------------------------------------------------------------------- */ static int TcpCloseProc( | | | 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 | * Closes the socket of the channel. * *---------------------------------------------------------------------- */ static int TcpCloseProc( void *instanceData, /* The socket to close. */ TCL_UNUSED(Tcl_Interp *)) { TcpState *statePtr = (TcpState *)instanceData; int errorCode = 0; TcpFdList *fds; /* |
︙ | ︙ | |||
623 624 625 626 627 628 629 | while (fds != NULL) { TcpFdList *next = fds->next; Tcl_Free(fds); fds = next; } if (statePtr->addrlist != NULL) { | | | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 | while (fds != NULL) { TcpFdList *next = fds->next; Tcl_Free(fds); fds = next; } if (statePtr->addrlist != NULL) { freeaddrinfo(statePtr->addrlist); } if (statePtr->myaddrlist != NULL) { freeaddrinfo(statePtr->myaddrlist); } Tcl_Free(statePtr); return errorCode; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
651 652 653 654 655 656 657 | * Shuts down one side of the socket. * *---------------------------------------------------------------------- */ static int TcpClose2Proc( | | | 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 | * Shuts down one side of the socket. * *---------------------------------------------------------------------- */ static int TcpClose2Proc( void *instanceData, /* The socket to close. */ TCL_UNUSED(Tcl_Interp *), int flags) /* Flags that indicate which side to close. */ { TcpState *statePtr = (TcpState *)instanceData; int readError = 0; int writeError = 0; |
︙ | ︙ | |||
702 703 704 705 706 707 708 | #pragma GCC diagnostic ignored "-Wstrict-aliasing" #endif static inline int IPv6AddressNeedsNumericRendering( struct in6_addr addr) { if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) { | | | | | | | | | | | | | | | | | | | | | | | 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 | #pragma GCC diagnostic ignored "-Wstrict-aliasing" #endif static inline int IPv6AddressNeedsNumericRendering( struct in6_addr addr) { if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) { return 1; } /* * The IN6_IS_ADDR_V4MAPPED macro has a problem with aliasing warnings on * at least some versions of OSX. */ if (!IN6_IS_ADDR_V4MAPPED(&addr)) { return 0; } return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0 && addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0); } #if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5)))) #pragma GCC diagnostic pop #endif #endif /* NEED_FAKE_RFC2553 */ static void TcpHostPortList( Tcl_Interp *interp, Tcl_DString *dsPtr, address addr, socklen_t salen) { #define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" char host[NI_MAXHOST], nhost[NI_MAXHOST], nport[NI_MAXSERV]; int flags = 0; getnameinfo(&addr.sa, salen, nhost, sizeof(nhost), nport, sizeof(nport), NI_NUMERICHOST | NI_NUMERICSERV); Tcl_DStringAppendElement(dsPtr, nhost); /* * We don't want to resolve INADDR_ANY and sin6addr_any; they can * sometimes cause problems (and never have a name). */ if (addr.sa.sa_family == AF_INET) { if (addr.sa4.sin_addr.s_addr == INADDR_ANY) { flags |= NI_NUMERICHOST; } #ifndef NEED_FAKE_RFC2553 } else if (addr.sa.sa_family == AF_INET6) { if (IPv6AddressNeedsNumericRendering(addr.sa6.sin6_addr)) { flags |= NI_NUMERICHOST; } #endif /* NEED_FAKE_RFC2553 */ } /* * Check if reverse DNS has been switched off globally. */ if (interp != NULL && Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) { flags |= NI_NUMERICHOST; } if (getnameinfo(&addr.sa, salen, host, sizeof(host), NULL, 0, flags) == 0) { /* * Reverse mapping worked. */ Tcl_DStringAppendElement(dsPtr, host); } else { /* * Reverse mapping failed - use the numeric rep once more. */ Tcl_DStringAppendElement(dsPtr, nhost); } Tcl_DStringAppendElement(dsPtr, nport); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
901 902 903 904 905 906 907 | } if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { socklen_t optlen = sizeof(int); WaitForConnect(statePtr, NULL); | | | | | | | | | | | | | | | | | | | | | 901 902 903 904 905 906 907 908 909 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 | } if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { socklen_t optlen = sizeof(int); WaitForConnect(statePtr, NULL); if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { /* * Suppress errors as long as we are not done. */ errno = 0; } else if (statePtr->connectError != 0) { errno = statePtr->connectError; statePtr->connectError = 0; } else { int err; getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &err, &optlen); errno = err; } if (errno != 0) { Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), TCL_INDEX_NONE); } return TCL_OK; } if ((len > 1) && (optionName[1] == 'c') && (strncmp(optionName, "-connecting", len) == 0)) { WaitForConnect(statePtr, NULL); Tcl_DStringAppend(dsPtr, GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE); return TCL_OK; } if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { address peername; socklen_t size = sizeof(peername); WaitForConnect(statePtr, NULL); if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { /* * In async connect output an empty string */ |
︙ | ︙ | |||
957 958 959 960 961 962 963 | * Peername fetch succeeded - output list */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } | | | | | | | | 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 | * Peername fetch succeeded - output list */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } TcpHostPortList(interp, dsPtr, peername, size); if (len) { return TCL_OK; } Tcl_DStringEndSublist(dsPtr); } else { /* * getpeername failed - but if we were asked for all the options * (len==0), don't flag an error at that point because it could be * an fconfigure request on a server socket (which have no peer). * Same must be done on win&mac. */ if (len) { if (interp) { TclPrintfResult(interp, "can't get peername: %s", Tcl_PosixError(interp)); } return TCL_ERROR; } } } if ((len == 0) || ((len > 1) && (optionName[1] == 's') && |
︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 | if (found) { if (len) { return TCL_OK; } Tcl_DStringEndSublist(dsPtr); } else { if (interp) { | | | | 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 | if (found) { if (len) { return TCL_OK; } Tcl_DStringEndSublist(dsPtr); } else { if (interp) { TclPrintfResult(interp, "can't get sockname: %s", Tcl_PosixError(interp)); } return TCL_ERROR; } } if ((len == 0) || ((len > 1) && (optionName[1] == 'k') && (strncmp(optionName, "-keepalive", len) == 0))) { |
︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 | if (len > 0) { return TCL_OK; } } if (len > 0) { return Tcl_BadChannelOption(interp, optionName, | | | 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 | if (len > 0) { return TCL_OK; } } if (len > 0) { return Tcl_BadChannelOption(interp, optionName, "connecting keepalive nodelay peername sockname"); } return TCL_OK; } /* * ---------------------------------------------------------------------- |
︙ | ︙ | |||
1162 1163 1164 1165 1166 1167 1168 | newmask = TCL_WRITABLE; } Tcl_NotifyChannel(statePtr->channel, newmask); } static void TcpWatchProc( | | | | | | | | | | | | > | 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 | newmask = TCL_WRITABLE; } Tcl_NotifyChannel(statePtr->channel, newmask); } static void TcpWatchProc( void *instanceData, /* The socket state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { TcpState *statePtr = (TcpState *)instanceData; if (statePtr->acceptProc != NULL) { /* * Make sure we don't mess with server sockets since they will never * be readable or writable at the Tcl level. This keeps Tcl scripts * from interfering with the -accept behavior (bug #3394732). */ return; } if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { /* * Async sockets use a FileHandler internally while connecting, so we * need to cache this request until the connection has succeeded. */ statePtr->filehandlers = mask; } else if (mask) { /* * Whether it is a bug or feature or otherwise, it is a fact of life * that on at least some Linux kernels select() fails to report that a * socket file descriptor is writable when the other end of the socket * is closed. This is in contrast to the guarantees Tcl makes that * its channels become writable and fire writable events on an error * condition. This has caused a leak of file descriptors in a state of |
︙ | ︙ | |||
1234 1235 1236 1237 1238 1239 1240 | * None. * * ---------------------------------------------------------------------- */ static int TcpGetHandleProc( | | | | 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 | * None. * * ---------------------------------------------------------------------- */ static int TcpGetHandleProc( void *instanceData, /* The socket state. */ TCL_UNUSED(int) /*direction*/, void **handlePtr) /* Where to store the handle. */ { TcpState *statePtr = (TcpState *)instanceData; *handlePtr = INT2PTR(statePtr->fds.fd); return TCL_OK; } |
︙ | ︙ | |||
1258 1259 1260 1261 1262 1263 1264 | * attempt has succeeded or failed. * * ---------------------------------------------------------------------- */ static void TcpAsyncCallback( | | | | | | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 | * attempt has succeeded or failed. * * ---------------------------------------------------------------------- */ static void TcpAsyncCallback( void *clientData, /* The socket state. */ TCL_UNUSED(int) /*mask*/) { TcpConnect(NULL, (TcpState *)clientData); } /* * ---------------------------------------------------------------------- * * TcpConnect -- * * This function opens a new socket in client mode. * * Results: * TCL_OK, if the socket was successfully connected or an asynchronous * connection is in progress. If an error occurs, TCL_ERROR is returned * and an error message is left in interp. * * Side effects: * Opens a socket. * * Remarks: * A single host name may resolve to more than one IP address, e.g. for * an IPv4/IPv6 dual stack host. For handling asynchronously connecting |
︙ | ︙ | |||
1306 1307 1308 1309 1310 1311 1312 | socklen_t optlen; int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING); int ret = -1, error = EHOSTUNREACH; int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT); static const int reuseaddr = 1; if (async_callback) { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 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 | socklen_t optlen; int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING); int ret = -1, error = EHOSTUNREACH; int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT); static const int reuseaddr = 1; if (async_callback) { goto reenter; } for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; statePtr->addr = statePtr->addr->ai_next) { for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; statePtr->myaddr = statePtr->myaddr->ai_next) { /* * No need to try combinations of local and remote addresses of * different families. */ if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) { continue; } /* * Close the socket if it is still open from the last unsuccessful * iteration. */ if (statePtr->fds.fd >= 0) { close(statePtr->fds.fd); statePtr->fds.fd = -1; errno = 0; } statePtr->fds.fd = socket(statePtr->addr->ai_family, SOCK_STREAM, 0); if (statePtr->fds.fd < 0) { continue; } /* * Set the close-on-exec flag so that the socket will not get * inherited by child processes. */ fcntl(statePtr->fds.fd, F_SETFD, FD_CLOEXEC); /* * Set kernel space buffering */ TclSockMinimumBuffers(INT2PTR(statePtr->fds.fd), SOCKET_BUFSIZE); if (async) { ret = TclUnixSetBlockingMode(statePtr->fds.fd, TCL_MODE_NONBLOCKING); if (ret < 0) { continue; } } /* * Must reset the error variable here, before we use it for the * first time in this iteration. */ error = 0; (void) setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr, statePtr->myaddr->ai_addrlen); if (ret < 0) { error = errno; continue; } /* * Attempt to connect. The connect may fail at present with an * EINPROGRESS but at a later time it will complete. The caller * will set up a file handler on the socket if she is interested * in being informed when the connect completes. */ ret = connect(statePtr->fds.fd, statePtr->addr->ai_addr, statePtr->addr->ai_addrlen); if (ret < 0) { error = errno; } if (ret < 0 && errno == EINPROGRESS) { Tcl_CreateFileHandler(statePtr->fds.fd, TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, statePtr); errno = EWOULDBLOCK; SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); return TCL_OK; reenter: CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); Tcl_DeleteFileHandler(statePtr->fds.fd); /* * Read the error state from the socket to see if the async * connection has succeeded or failed. As this clears the * error condition, we cache the status in the socket state * struct for later retrieval by [fconfigure -error]. */ optlen = sizeof(int); getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &error, &optlen); errno = error; } if (error == 0) { goto out; } } } out: statePtr->connectError = error; CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); if (async_callback) { /* * An asynchonous connection has finally succeeded or failed. */ TcpWatchProc(statePtr, statePtr->filehandlers); TclUnixSetBlockingMode(statePtr->fds.fd, statePtr->cachedBlocking); if (error != 0) { SET_BITS(statePtr->flags, TCP_ASYNC_FAILED); } /* * We need to forward the writable event that brought us here, because * upon reading of getsockopt(SO_ERROR), at least some OSes clear the * writable state from the socket, and so a subsequent select() on * behalf of a script level [fileevent] would not fire. It doesn't * hurt that this is also called in the successful case and will save * the event mechanism one roundtrip through select(). */ if (statePtr->cachedBlocking == TCL_MODE_NONBLOCKING) { Tcl_NotifyChannel(statePtr->channel, TCL_WRITABLE); } } if (error != 0) { /* |
︙ | ︙ | |||
1531 1532 1533 1534 1535 1536 1537 | statePtr->fds.fd = -1; /* * Create a new client socket and wrap it in a channel. */ if (TcpConnect(interp, statePtr) != TCL_OK) { | | | | | 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 | statePtr->fds.fd = -1; /* * Create a new client socket and wrap it in a channel. */ if (TcpConnect(interp, statePtr) != TCL_OK) { TcpCloseProc(statePtr, NULL); return NULL; } snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr)); statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr, TCL_READABLE | TCL_WRITABLE); if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation", "auto crlf") == TCL_ERROR) { Tcl_CloseEx(NULL, statePtr->channel, 0); return NULL; } return statePtr->channel; } |
︙ | ︙ | |||
1565 1566 1567 1568 1569 1570 1571 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeTcpClientChannel( | | | | 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeTcpClientChannel( void *sock) /* The socket to wrap up into a channel. */ { return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock, TCL_READABLE | TCL_WRITABLE); } /* *---------------------------------------------------------------------- * * TclpMakeTcpClientChannelMode -- * |
︙ | ︙ | |||
1590 1591 1592 1593 1594 1595 1596 | * None. * *---------------------------------------------------------------------- */ void * TclpMakeTcpClientChannelMode( | | | 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 | * None. * *---------------------------------------------------------------------- */ void * TclpMakeTcpClientChannelMode( void *sock, /* The socket to wrap up into a channel. */ int mode) /* OR'ed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { TcpState *statePtr; char channelName[SOCK_CHAN_LENGTH]; statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState)); |
︙ | ︙ | |||
1637 1638 1639 1640 1641 1642 1643 | Tcl_Channel Tcl_OpenTcpServerEx( Tcl_Interp *interp, /* For error reporting - may be NULL. */ const char *service, /* Port number to open. */ const char *myHost, /* Name of local host. */ unsigned int flags, /* Flags. */ | | | 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 | Tcl_Channel Tcl_OpenTcpServerEx( Tcl_Interp *interp, /* For error reporting - may be NULL. */ const char *service, /* Port number to open. */ const char *myHost, /* Name of local host. */ unsigned int flags, /* Flags. */ int backlog, /* Length of OS listen backlog queue. */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ void *acceptProcData) /* Data for the callback. */ { int status = 0, sock = -1, optvalue, port, chosenport; struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */ |
︙ | ︙ | |||
1675 1676 1677 1678 1679 1680 1681 | */ int retry = 0; #define MAXRETRY 10 repeat: if (retry > 0) { | | | | | | | | | | | | | | | 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 | */ int retry = 0; #define MAXRETRY 10 repeat: if (retry > 0) { if (statePtr != NULL) { TcpCloseProc(statePtr, NULL); statePtr = NULL; } if (addrlist != NULL) { freeaddrinfo(addrlist); addrlist = NULL; } if (retry >= MAXRETRY) { goto error; } } retry++; chosenport = 0; if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) { errorMsg = "invalid port number"; goto error; } if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) { my_errno = errno; goto error; } for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, addrPtr->ai_protocol); if (sock == -1) { if (howfar < SOCKET) { howfar = SOCKET; my_errno = errno; } continue; } |
︙ | ︙ | |||
1751 1752 1753 1754 1755 1756 1757 | #else optvalue = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, (char *) &optvalue, sizeof(optvalue)); #endif } | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 | #else optvalue = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, (char *) &optvalue, sizeof(optvalue)); #endif } /* * Make sure we use the same port number when opening two server * sockets for IPv4 and IPv6 on a random port. * * As sockaddr_in6 uses the same offset and size for the port member * as sockaddr_in, we can handle both through the IPv4 API. */ if (port == 0 && chosenport != 0) { ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = htons(chosenport); } #ifdef IPV6_V6ONLY /* * Missing on: Solaris 2.8 */ if (addrPtr->ai_family == AF_INET6) { int v6only = 1; (void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY, &v6only, sizeof(v6only)); } #endif /* IPV6_V6ONLY */ status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen); if (status == -1) { if (howfar < BIND) { howfar = BIND; my_errno = errno; } close(sock); sock = -1; if (port == 0 && errno == EADDRINUSE) { goto repeat; } continue; } if (port == 0 && chosenport == 0) { address sockname; socklen_t namelen = sizeof(sockname); /* * Synchronize port numbers when binding to port 0 of multiple * addresses. */ if (getsockname(sock, &sockname.sa, &namelen) >= 0) { chosenport = ntohs(sockname.sa4.sin_port); } } if (backlog < 0) { backlog = SOMAXCONN; } status = listen(sock, backlog); if (status < 0) { if (howfar < LISTEN) { howfar = LISTEN; my_errno = errno; } close(sock); sock = -1; if (port == 0 && errno == EADDRINUSE) { goto repeat; } continue; } if (statePtr == NULL) { /* * Allocate a new TcpState for this socket. */ statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->acceptProc = acceptProc; statePtr->acceptProcData = acceptProcData; snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr)); newfds = &statePtr->fds; } else { newfds = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList)); memset(newfds, (int) 0, sizeof(TcpFdList)); fds->next = newfds; } newfds->fd = sock; newfds->statePtr = statePtr; fds = newfds; /* * Set up the callback mechanism for accepting connections from new * clients. */ Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds); } error: if (addrlist != NULL) { freeaddrinfo(addrlist); } if (statePtr != NULL) { statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr, 0); return statePtr->channel; } if (interp != NULL) { Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", TCL_INDEX_NONE); if (errorMsg == NULL) { errno = my_errno; Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), TCL_INDEX_NONE); } else { Tcl_AppendToObj(errorObj, errorMsg, TCL_INDEX_NONE); } Tcl_SetObjResult(interp, errorObj); } if (sock != -1) { close(sock); } return NULL; } |
︙ | ︙ | |||
1892 1893 1894 1895 1896 1897 1898 | * connection acceptance mechanism. * *---------------------------------------------------------------------- */ static void TcpAccept( | | | 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 | * connection acceptance mechanism. * *---------------------------------------------------------------------- */ static void TcpAccept( void *data, /* Callback token. */ TCL_UNUSED(int) /*mask*/) { TcpFdList *fds = (TcpFdList *)data; /* Client data of server socket. */ int newsock; /* The new client socket */ TcpState *newSockState; /* State for new socket. */ address addr; /* The remote address */ socklen_t len; /* For accept interface */ |
︙ | ︙ | |||
1930 1931 1932 1933 1934 1935 1936 | newSockState, TCL_READABLE | TCL_WRITABLE); Tcl_SetChannelOption(NULL, newSockState->channel, "-translation", "auto crlf"); if (fds->statePtr->acceptProc != NULL) { getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port), | | | | 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 | newSockState, TCL_READABLE | TCL_WRITABLE); Tcl_SetChannelOption(NULL, newSockState->channel, "-translation", "auto crlf"); if (fds->statePtr->acceptProc != NULL) { getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port), NI_NUMERICHOST|NI_NUMERICSERV); fds->statePtr->acceptProc(fds->statePtr->acceptProcData, newSockState->channel, host, atoi(port)); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 * indent-tabs-mode: nil * End: */ |
Changes to unix/tclUnixThrd.c.
︙ | ︙ | |||
209 210 211 212 213 214 215 | *---------------------------------------------------------------------- */ int TclpThreadCreate( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ | | | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | *---------------------------------------------------------------------- */ int TclpThreadCreate( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ void *clientData, /* The one argument to Main() */ size_t stackSize, /* Size of stack for the new thread */ int flags) /* Flags controlling behaviour of the new * thread. */ { #if TCL_THREADS pthread_attr_t attr; pthread_t theThread; int result; |
︙ | ︙ |
Changes to unix/tclXtNotify.c.
︙ | ︙ | |||
29 30 31 32 33 34 35 | * time FileHandlerEventProc was called for * this file. */ XtInputId read; /* Xt read callback handle. */ XtInputId write; /* Xt write callback handle. */ XtInputId except; /* Xt exception callback handle. */ Tcl_FileProc *proc; /* Procedure to call, in the style of * Tcl_CreateFileHandler. */ | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | * time FileHandlerEventProc was called for * this file. */ XtInputId read; /* Xt read callback handle. */ XtInputId write; /* Xt write callback handle. */ XtInputId except; /* Xt exception callback handle. */ Tcl_FileProc *proc; /* Procedure to call, in the style of * Tcl_CreateFileHandler. */ void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; /* * The following structure is what is added to the Tcl event queue when file * handlers are ready to fire. */ |
︙ | ︙ | |||
259 260 261 262 263 264 265 | * Replaces any previous timer. * *---------------------------------------------------------------------- */ static void SetTimer( | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | * Replaces any previous timer. * *---------------------------------------------------------------------- */ static void SetTimer( const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { unsigned long timeout; if (!initialized) { InitNotifier(); } |
︙ | ︙ | |||
335 336 337 338 339 340 341 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Procedure to call for each selected * event. */ | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 | int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc, /* Procedure to call for each selected * event. */ void *clientData) /* Arbitrary data to pass to proc. */ { FileHandler *filePtr; if (!initialized) { InitNotifier(); } |
︙ | ︙ | |||
623 624 625 626 627 628 629 | * Queues file events that are detected by the select. * *---------------------------------------------------------------------- */ static int WaitForEvent( | | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 | * Queues file events that are detected by the select. * *---------------------------------------------------------------------- */ static int WaitForEvent( const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { int timeout; if (!initialized) { InitNotifier(); } |
︙ | ︙ |
Changes to win/tclWin32Dll.c.
︙ | ︙ | |||
428 429 430 431 432 433 434 | * instruction in the four integers designated by 'regsPtr' * *---------------------------------------------------------------------- */ int TclWinCPUID( | | | | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 | * instruction in the four integers designated by 'regsPtr' * *---------------------------------------------------------------------- */ int TclWinCPUID( int index, /* Which CPUID value to retrieve. */ int *regsPtr) /* Registers after the CPUID. */ { int status = TCL_ERROR; #if defined(HAVE_INTRIN_H) && defined(_WIN64) && defined(HAVE_CPUID) __cpuid((int *)regsPtr, index); status = TCL_OK; |
︙ | ︙ |
Changes to win/tclWinChan.c.
︙ | ︙ | |||
380 381 382 383 384 385 386 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int FileBlockProc( | | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int FileBlockProc( void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { FileInfo *infoPtr = (FileInfo *)instanceData; /* * Files on Windows can not be switched between blocking and nonblocking, |
︙ | ︙ | |||
419 420 421 422 423 424 425 | * Closes the physical channel * *---------------------------------------------------------------------- */ static int FileCloseProc( | | | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 | * Closes the physical channel * *---------------------------------------------------------------------- */ static int FileCloseProc( void *instanceData, /* Pointer to FileInfo structure. */ TCL_UNUSED(Tcl_Interp *), int flags) { FileInfo *fileInfoPtr = (FileInfo *)instanceData; FileInfo *infoPtr; ThreadSpecificData *tsdPtr; int errorCode = 0; |
︙ | ︙ | |||
469 470 471 472 473 474 475 | /* * This channel exists on the thread local list. It should have * been removed by an earlier Threadaction call, but do that now * since just deallocating fileInfoPtr would leave an deallocated * pointer on the thread local list. */ | | | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 | /* * This channel exists on the thread local list. It should have * been removed by an earlier Threadaction call, but do that now * since just deallocating fileInfoPtr would leave an deallocated * pointer on the thread local list. */ FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE); break; } } Tcl_Free(fileInfoPtr); return errorCode; } |
︙ | ︙ | |||
497 498 499 500 501 502 503 | * operations. * *---------------------------------------------------------------------- */ static long long FileWideSeekProc( | | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 | * operations. * *---------------------------------------------------------------------- */ static long long FileWideSeekProc( void *instanceData, /* File state. */ long long offset, /* Offset to seek to. */ int mode, /* Relative to where should we seek? */ int *errorCodePtr) /* To store error code. */ { FileInfo *infoPtr = (FileInfo *)instanceData; DWORD moveMethod; LONG newPos, newPosHigh; |
︙ | ︙ | |||
549 550 551 552 553 554 555 | * Truncates the file, may move file pointers too. * *---------------------------------------------------------------------- */ static int FileTruncateProc( | | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 | * Truncates the file, may move file pointers too. * *---------------------------------------------------------------------- */ static int FileTruncateProc( void *instanceData, /* File state. */ long long length) /* Length to truncate at. */ { FileInfo *infoPtr = (FileInfo *)instanceData; LONG newPos, newPosHigh, oldPos, oldPosHigh; /* * Save where we were... |
︙ | ︙ | |||
625 626 627 628 629 630 631 | * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int FileInputProc( | | | 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 | * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int FileInputProc( void *instanceData, /* File state. */ char *buf, /* Where to store data read. */ int bufSize, /* Num bytes available in buffer. */ int *errorCode) /* Where to store error code. */ { FileInfo *infoPtr = (FileInfo *)instanceData; DWORD bytesRead; |
︙ | ︙ | |||
680 681 682 683 684 685 686 | * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int FileOutputProc( | | | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 | * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int FileOutputProc( void *instanceData, /* File state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ { FileInfo *infoPtr = (FileInfo *)instanceData; DWORD bytesWritten; |
︙ | ︙ | |||
727 728 729 730 731 732 733 | * None. * *---------------------------------------------------------------------- */ static void FileWatchProc( | | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 | * None. * *---------------------------------------------------------------------- */ static void FileWatchProc( void *instanceData, /* File state. */ int mask) /* What events to watch for; OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { FileInfo *infoPtr = (FileInfo *)instanceData; Tcl_Time blockTime = { 0, 0 }; |
︙ | ︙ | |||
766 767 768 769 770 771 772 | * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc( | | | | 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 | * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc( void *instanceData, /* The file state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ void **handlePtr) /* Where to store the handle. */ { FileInfo *infoPtr = (FileInfo *)instanceData; if (!TEST_FLAG(direction, infoPtr->validMask)) { return TCL_ERROR; } |
︙ | ︙ | |||
887 888 889 890 891 892 893 | mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 6; /* * We don't construct a Tcl_StatBuf; we're using the info immediately. */ TclNewObj(dictObj); | | < | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 | mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 6; /* * We don't construct a Tcl_StatBuf; we're using the info immediately. */ TclNewObj(dictObj); #define STORE_ELEM(name, value) StoreElementInDict(dictObj, name, value) STORE_ELEM("dev", Tcl_NewWideIntObj((long) dev)); STORE_ELEM("ino", Tcl_NewWideIntObj((long long) inode)); STORE_ELEM("nlink", Tcl_NewIntObj(nlink)); STORE_ELEM("uid", Tcl_NewIntObj(0)); STORE_ELEM("gid", Tcl_NewIntObj(0)); STORE_ELEM("size", Tcl_NewWideIntObj((long long) size)); |
︙ | ︙ | |||
917 918 919 920 921 922 923 | #undef STORE_ELEM return dictObj; } static int FileGetOptionProc( | | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 | #undef STORE_ELEM return dictObj; } static int FileGetOptionProc( void *instanceData, /* The file state. */ Tcl_Interp *interp, /* For error reporting. */ const char *optionName, /* What option to read, or NULL for all. */ Tcl_DString *dsPtr) /* Where to write the value read. */ { FileInfo *infoPtr = (FileInfo *)instanceData; int valid = 0; /* Flag if valid option parsed. */ int len; |
︙ | ︙ | |||
1210 1211 1212 1213 1214 1215 1216 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeFileChannel( | | | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeFileChannel( void *rawHandle, /* OS level handle */ int mode) /* OR'ed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__) TCLEXCEPTION_REGISTRATION registration; #endif char channelName[16 + TCL_INTEGER_SPACE]; |
︙ | ︙ | |||
1458 1459 1460 1461 1462 1463 1464 | return (Tcl_Channel) NULL; } /* * Set up the normal channel options for stdio handles. */ | | | | 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 | return (Tcl_Channel) NULL; } /* * Set up the normal channel options for stdio handles. */ if (Tcl_SetChannelOption(NULL,channel,"-translation","auto")!=TCL_OK || Tcl_SetChannelOption(NULL,channel,"-buffering",bufMode)!=TCL_OK) { Tcl_CloseEx(NULL, channel, 0); return (Tcl_Channel) NULL; } return channel; } /* |
︙ | ︙ | |||
1679 1680 1681 1682 1683 1684 1685 | } } } return type; } | | | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 | } } } return type; } /* *---------------------------------------------------------------------- * * NativeIsComPort -- * * Determines if a path refers to a Windows serial port. A simple and * efficient solution is to use a "name hint" to detect COM ports by * their filename instead of resorting to a syscall to detect serialness |
︙ | ︙ |
Changes to win/tclWinConsole.c.
︙ | ︙ | |||
90 91 92 93 94 95 96 | #endif /* * Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1] * and bufPtr[0]:bufPtr[length - (size-start)]. */ typedef struct RingBuffer { | | | | | | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | #endif /* * Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1] * and bufPtr[0]:bufPtr[length - (size-start)]. */ typedef struct RingBuffer { char *bufPtr; /* Pointer to buffer storage */ Tcl_Size capacity; /* Size of the buffer in RingBufferChar */ Tcl_Size start; /* Start of the data within the buffer. */ Tcl_Size length; /* Number of RingBufferChar*/ } RingBuffer; #define RingBufferLength(ringPtr_) ((ringPtr_)->length) #define RingBufferHasFreeSpace(ringPtr_) ((ringPtr_)->length < (ringPtr_)->capacity) #define RINGBUFFER_ASSERT(ringPtr_) assert(RingBufferCheck(ringPtr_)) /* * The Win32 console API does not support non-blocking I/O in any form. Thus |
︙ | ︙ | |||
121 122 123 124 125 126 127 | * * Note on reference counting - a ConsoleHandleInfo instance has multiple * references to it - one each from every channel that is attached to it * plus one from the console thread itself which also serves as the reference * from gConsoleHandleInfoList. */ typedef struct ConsoleHandleInfo { | | < | | < | | | < | | | | | | | | | | | | 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 | * * Note on reference counting - a ConsoleHandleInfo instance has multiple * references to it - one each from every channel that is attached to it * plus one from the console thread itself which also serves as the reference * from gConsoleHandleInfoList. */ typedef struct ConsoleHandleInfo { struct ConsoleHandleInfo *nextPtr; /* Process-global list of consoles */ HANDLE console; /* Console handle */ HANDLE consoleThread; /* Handle to thread doing actual i/o on the console */ SRWLOCK lock; /* Controls access to this structure. * Cheaper than CRITICAL_SECTION but note does not * support recursive locks or Try* style attempts.*/ CONDITION_VARIABLE consoleThreadCV;/* For awakening console thread */ CONDITION_VARIABLE interpThreadCV; /* For awakening interpthread(s) */ RingBuffer buffer; /* Buffer for data transferred between console * threads and Tcl threads. For input consoles, * written by the console thread and read by Tcl * threads. The converse for output threads */ DWORD initMode; /* Initial console mode. */ DWORD lastError; /* An error caused by the last background * operation. Set to 0 if no error has been * detected. */ int numRefs; /* See comments above */ int permissions; /* TCL_READABLE for input consoles, TCL_WRITABLE * for output. Only one or the other can be set. */ int flags; #define CONSOLE_DATA_AWAITED 0x0001 /* An interpreter is awaiting data */ } ConsoleHandleInfo; /* * This structure describes per-instance data for a console based channel. * |
︙ | ︙ | |||
182 183 184 185 186 187 188 | HANDLE handle; /* Console handle */ Tcl_ThreadId threadId; /* Id of owning thread */ struct ConsoleChannelInfo *nextWatchingChannelPtr; /* Pointer to next channel watching events. */ Tcl_Channel channel; /* Pointer to channel structure. */ DWORD initMode; /* Initial console mode. */ int numRefs; /* See comments above */ | | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 | HANDLE handle; /* Console handle */ Tcl_ThreadId threadId; /* Id of owning thread */ struct ConsoleChannelInfo *nextWatchingChannelPtr; /* Pointer to next channel watching events. */ Tcl_Channel channel; /* Pointer to channel structure. */ DWORD initMode; /* Initial console mode. */ int numRefs; /* See comments above */ int permissions; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which operations are valid on the file. */ int watchMask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ int flags; /* State flags */ #define CONSOLE_EVENT_QUEUED 0x0001 /* Notification event already queued */ |
︙ | ︙ | |||
297 298 299 300 301 302 303 | /* * This structure describes the channel type structure for command console * based IO. */ static const Tcl_ChannelType consoleChannelType = { | | | | | | | | | | | | | | | | | | | 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 | /* * This structure describes the channel type structure for command console * based IO. */ static const Tcl_ChannelType consoleChannelType = { "console", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ NULL, /* Close proc. */ ConsoleInputProc, /* Input proc. */ ConsoleOutputProc, /* Output proc. */ NULL, /* Seek proc. */ ConsoleSetOptionProc, /* Set option proc. */ ConsoleGetOptionProc, /* Get option proc. */ ConsoleWatchProc, /* Set up notifier to watch the channel. */ ConsoleGetHandleProc, /* Get an OS handle from channel. */ ConsoleCloseProc, /* close2proc. */ ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */ NULL, /* Flush proc. */ NULL, /* Handler proc. */ NULL, /* Wide seek proc. */ ConsoleThreadActionProc, /* Thread action proc. */ NULL /* Truncation proc. */ }; /* *------------------------------------------------------------------------ * * RingBufferInit -- * |
︙ | ︙ | |||
753 754 755 756 757 758 759 | /* *---------------------------------------------------------------------- * * ConsoleSetupProc -- * * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an * event. It walks the channel list and if any input channel has data | | | | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 | /* *---------------------------------------------------------------------- * * ConsoleSetupProc -- * * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an * event. It walks the channel list and if any input channel has data * available or output channel has space for data, sets the event loop * blocking time to 0 so that it will poll immediately. * * Results: * None. * * Side effects: * Adjusts the block time if needed. * |
︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 | * A console reader or writer thread is started. The returned structure * is placed on the active console handler list gConsoleHandleInfoList. * *------------------------------------------------------------------------ */ static ConsoleHandleInfo * AllocateConsoleHandleInfo( | | | | | | | < < | | | | 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 | * A console reader or writer thread is started. The returned structure * is placed on the active console handler list gConsoleHandleInfoList. * *------------------------------------------------------------------------ */ static ConsoleHandleInfo * AllocateConsoleHandleInfo( HANDLE consoleHandle, int permissions) /* TCL_READABLE or TCL_WRITABLE */ { ConsoleHandleInfo *handleInfoPtr; DWORD consoleMode; handleInfoPtr = (ConsoleHandleInfo *)Tcl_Alloc(sizeof(*handleInfoPtr)); memset(handleInfoPtr, 0, sizeof(*handleInfoPtr)); handleInfoPtr->console = consoleHandle; InitializeSRWLock(&handleInfoPtr->lock); InitializeConditionVariable(&handleInfoPtr->consoleThreadCV); InitializeConditionVariable(&handleInfoPtr->interpThreadCV); RingBufferInit(&handleInfoPtr->buffer, CONSOLE_BUFFER_SIZE); handleInfoPtr->lastError = 0; handleInfoPtr->permissions = permissions; handleInfoPtr->numRefs = 1; /* See function header */ if (permissions == TCL_READABLE) { GetConsoleMode(consoleHandle, &handleInfoPtr->initMode); consoleMode = handleInfoPtr->initMode; consoleMode &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); consoleMode |= ENABLE_LINE_INPUT; SetConsoleMode(consoleHandle, consoleMode); } handleInfoPtr->consoleThread = CreateThread( NULL, /* default security descriptor */ 2*CONSOLE_BUFFER_SIZE, /* Stack size - gets rounded up to granularity */ permissions == TCL_READABLE ? ConsoleReaderThread : ConsoleWriterThread, handleInfoPtr, /* Pass to thread */ 0, /* Flags - no special cases */ NULL); /* Don't care about thread id */ if (handleInfoPtr->consoleThread == NULL) { /* Note - SRWLock and condition variables do not need finalization */ RingBufferClear(&handleInfoPtr->buffer); Tcl_Free(handleInfoPtr); return NULL; } |
︙ | ︙ | |||
2258 2259 2260 2261 2262 2263 2264 | * May modify an option on a console. Sets Error message if needed (by * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int ConsoleSetOptionProc( | | | 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 | * May modify an option on a console. Sets Error message if needed (by * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int ConsoleSetOptionProc( void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ { ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; int len = strlen(optionName); int vlen = strlen(value); |
︙ | ︙ | |||
2345 2346 2347 2348 2349 2350 2351 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int ConsoleGetOptionProc( | | | 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int ConsoleGetOptionProc( void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ { ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; int valid = 0; /* Flag if valid option parsed. */ unsigned int len; |
︙ | ︙ |
Changes to win/tclWinDde.c.
︙ | ︙ | |||
88 89 90 91 92 93 94 | #define DDE_FLAG_BINARY 2 #define DDE_FLAG_FORCE 4 TCL_DECLARE_MUTEX(ddeMutex) #if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 | | < | < | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | #define DDE_FLAG_BINARY 2 #define DDE_FLAG_FORCE 4 TCL_DECLARE_MUTEX(ddeMutex) #if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 # define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) # define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) # else # define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString # define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString # endif #ifndef Tcl_Size # define Tcl_Size int #endif |
︙ | ︙ | |||
308 309 310 311 312 313 314 | * *---------------------------------------------------------------------- */ static const WCHAR * DdeSetServerName( Tcl_Interp *interp, | | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | * *---------------------------------------------------------------------- */ static const WCHAR * DdeSetServerName( Tcl_Interp *interp, const WCHAR *name, /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ int flags, /* DDE_FLAG_FORCE or 0 */ Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle * incoming Dde eval's */ { int suffix; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; const WCHAR *actualName; |
︙ | ︙ | |||
513 514 515 516 517 518 519 | * The interpreter given by riPtr is unregistered. * *---------------------------------------------------------------------- */ static void DeleteProc( | | | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 | * The interpreter given by riPtr is unregistered. * *---------------------------------------------------------------------- */ static void DeleteProc( void *clientData) /* The interp we are deleting. */ { RegisteredInterp *riPtr = (RegisteredInterp *) clientData; RegisteredInterp *searchPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL; (searchPtr != NULL) && (searchPtr != riPtr); |
︙ | ︙ | |||
1301 1302 1303 1304 1305 1306 1307 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DdeObjCmd( | | | | | 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DdeObjCmd( void *dummy, /* Not used. */ Tcl_Interp *interp, /* The interp we are sending from */ Tcl_Size objc, /* Number of arguments */ Tcl_Obj *const *objv) /* The arguments */ { static const char *const ddeCommands[] = { "servername", "execute", "poke", "request", "services", "eval", NULL}; enum DdeSubcommands { DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES, DDE_EVAL }; static const char *const ddeSrvOptions[] = { "-force", "-handler", "--", NULL }; enum DdeSrvOptions { DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST, }; static const char *const ddeExecOptions[] = { "-async", "-binary", NULL }; enum DdeExecOptions { DDE_EXEC_ASYNC, DDE_EXEC_BINARY }; static const char *const ddeEvalOptions[] = { "-async", NULL }; static const char *const ddeReqOptions[] = { "-binary", NULL }; |
︙ | ︙ |
Changes to win/tclWinFCmd.c.
︙ | ︙ | |||
900 901 902 903 904 905 906 | Tcl_Obj **errorPtr) { Tcl_DString ds; Tcl_DString srcString, dstString; Tcl_Obj *normSrcPtr, *normDestPtr; int ret; | | | | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 | Tcl_Obj **errorPtr) { Tcl_DString ds; Tcl_DString srcString, dstString; Tcl_Obj *normSrcPtr, *normDestPtr; int ret; normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr); normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr); if ((normSrcPtr == NULL) || (normDestPtr == NULL)) { return TCL_ERROR; } Tcl_DStringInit(&srcString); Tcl_DStringInit(&dstString); Tcl_UtfToWCharDString(TclGetString(normSrcPtr), TCL_INDEX_NONE, &srcString); |
︙ | ︙ | |||
1707 1708 1709 1710 1711 1712 1713 | * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ Tcl_DStringInit(&dsTemp); Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp); Tcl_DStringFree(&ds); | | | | 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 | * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ Tcl_DStringInit(&dsTemp); Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp); Tcl_DStringFree(&ds); tempPath = Tcl_DStringToObj(&dsTemp); Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); FindClose(handle); } } *attributePtrPtr = Tcl_FSJoinPath(splitPath, TCL_INDEX_NONE); if (splitPath != NULL) { |
︙ | ︙ |
Changes to win/tclWinFile.c.
︙ | ︙ | |||
493 494 495 496 497 498 499 | memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; hFile = CreateFileW(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile != INVALID_HANDLE_VALUE) { if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer, | | < | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 | memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; hFile = CreateFileW(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile != INVALID_HANDLE_VALUE) { if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer, REPARSE_MOUNTPOINT_HEADER_SIZE,NULL,0,&returnedLength,NULL)) { /* * Error setting junction. */ Tcl_WinConvertError(GetLastError()); CloseHandle(hFile); } else { |
︙ | ︙ | |||
580 581 582 583 584 585 586 | offset = 0; if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == '\\') { /* * Check whether this is a mounted volume. */ if (wcsncmp(reparseBuffer->MountPointReparseBuffer.PathBuffer, | | | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 | offset = 0; if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == '\\') { /* * Check whether this is a mounted volume. */ if (wcsncmp(reparseBuffer->MountPointReparseBuffer.PathBuffer, L"\\??\\Volume{",11) == 0) { char drive; /* * There is some confusion between \??\ and \\?\ which we have * to fix here. It doesn't seem very well documented. */ |
︙ | ︙ | |||
603 604 605 606 607 608 609 | reparseBuffer->MountPointReparseBuffer.PathBuffer); if (drive != -1) { char driveSpec[3] = { '\0', ':', '\0' }; driveSpec[0] = drive; | | | | | | | | 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 | reparseBuffer->MountPointReparseBuffer.PathBuffer); if (drive != -1) { char driveSpec[3] = { '\0', ':', '\0' }; driveSpec[0] = drive; retVal = Tcl_NewStringObj(driveSpec,2); Tcl_IncrRefCount(retVal); return retVal; } /* * This is actually a mounted drive, which doesn't exists as a * DOS drive letter. This means the path isn't actually a * link, although we partially treat it like one ('file type' * will return 'link'), but then the link will actually just * be treated like an ordinary directory. I don't believe any * serious inconsistency will arise from this, but it is * something to be aware of. */ goto invalidError; } else if (wcsncmp(reparseBuffer->MountPointReparseBuffer .PathBuffer, L"\\\\?\\",4) == 0) { /* * Strip off the prefix. */ offset = 4; } else if (wcsncmp(reparseBuffer->MountPointReparseBuffer .PathBuffer, L"\\??\\",4) == 0) { /* * Strip off the prefix. */ offset = 4; } } Tcl_DStringInit(&ds); Tcl_WCharToUtfDString( reparseBuffer->MountPointReparseBuffer.PathBuffer, reparseBuffer->MountPointReparseBuffer .SubstituteNameLength>>1, &ds); copy = Tcl_DStringValue(&ds)+offset; len = Tcl_DStringLength(&ds)-offset; retVal = Tcl_NewStringObj(copy,len); Tcl_IncrRefCount(retVal); Tcl_DStringFree(&ds); return retVal; } invalidError: Tcl_SetErrno(EINVAL); |
︙ | ︙ | |||
1434 1435 1436 1437 1438 1439 1440 | Tcl_DStringInit(bufferPtr); wDomain = NULL; domain = Tcl_UtfFindFirst(name, '@'); if (domain == NULL) { const char *ptr; | | | | | | | | | | | | | | | | | | | 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 | Tcl_DStringInit(bufferPtr); wDomain = NULL; domain = Tcl_UtfFindFirst(name, '@'); if (domain == NULL) { const char *ptr; /* * Treat the current user as a special case because the general case * below does not properly retrieve the path. The NetUserGetInfo * call returns an empty path and the code defaults to the user's * name in the profiles directory. On modern Windows systems, this * is generally wrong as when the account is a Microsoft account, * for example [email protected], the directory name is * abcde and not abcdefghi. * * Note we could have just used env(USERPROFILE) here but * the intent is to retrieve (as on Unix) the system's view * of the home irrespective of environment settings of HOME * and USERPROFILE. * * Fixing this for the general user needs more investigating but * at least for the current user we can use a direct call. */ ptr = TclpGetUserName(&ds); if (ptr != NULL && strcasecmp(name, ptr) == 0) { HANDLE hProcess; WCHAR buf[MAX_PATH]; DWORD nChars = sizeof(buf) / sizeof(buf[0]); /* Sadly GetCurrentProcessToken not in Win 7 so slightly longer */ hProcess = GetCurrentProcess(); /* Need not be closed */ |
︙ | ︙ | |||
1745 1746 1747 1748 1749 1750 1751 | * restrictions. Since the ACL tests are more likely wrong than * right, skip them. Moreover, the unix owner access permissions are * usually mapped to the Windows attributes, so if the user is the * file owner then the attrib checks above are correct (as far as they * go). */ | | | | 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 | * restrictions. Since the ACL tests are more likely wrong than * right, skip them. Moreover, the unix owner access permissions are * usually mapped to the Windows attributes, so if the user is the * file owner then the attrib checks above are correct (as far as they * go). */ if(!GetSecurityDescriptorOwner(sdPtr,&pSid,&SidDefaulted) || memcmp(GetSidIdentifierAuthority(pSid),&samba_unmapped, sizeof(SID_IDENTIFIER_AUTHORITY))==0) { HeapFree(GetProcessHeap(), 0, sdPtr); return 0; /* Attrib tests say access allowed. */ } /* * Perform security impersonation of the user and open the resulting |
︙ | ︙ | |||
1889 1890 1891 1892 1893 1894 1895 | * See chdir() documentation. * *---------------------------------------------------------------------- */ int TclpObjChdir( | | | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 | * See chdir() documentation. * *---------------------------------------------------------------------- */ int TclpObjChdir( Tcl_Obj *pathPtr) /* Path to new working directory. */ { int result; const WCHAR *nativePath; nativePath = (const WCHAR *)Tcl_FSGetNativePath(pathPtr); if (!nativePath) { |
︙ | ︙ | |||
2049 2050 2051 2052 2053 2054 2055 | FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); if (fileHandle != INVALID_HANDLE_VALUE) { BY_HANDLE_FILE_INFORMATION data; | | | | | | | | | | | | | | | | | | | | 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 | FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); if (fileHandle != INVALID_HANDLE_VALUE) { BY_HANDLE_FILE_INFORMATION data; if (GetFileInformationByHandle(fileHandle,&data) != TRUE) { fileType = GetFileType(fileHandle); CloseHandle(fileHandle); if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) { Tcl_SetErrno(ENOENT); return -1; } /* * Mock up the expected structure */ memset(&data, 0, sizeof(data)); statPtr->st_atime = 0; statPtr->st_mtime = 0; statPtr->st_ctime = 0; } else { CloseHandle(fileHandle); statPtr->st_atime = ToCTime(data.ftLastAccessTime); statPtr->st_mtime = ToCTime(data.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.ftCreationTime); } attr = data.dwFileAttributes; statPtr->st_size = ((long long) data.nFileSizeLow) | (((long long) data.nFileSizeHigh) << 32); /* * On Unix, for directories, nlink apparently depends on the number of * files in the directory. We could calculate that, but it would be a |
︙ | ︙ | |||
2130 2131 2132 2133 2134 2135 2136 | statPtr->st_mtime = ToCTime(data.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.ftCreationTime); } dev = NativeDev(nativePath); mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath)); if (fileType == FILE_TYPE_CHAR) { | | | | | | 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 | statPtr->st_mtime = ToCTime(data.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.ftCreationTime); } dev = NativeDev(nativePath); mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath)); if (fileType == FILE_TYPE_CHAR) { mode &= ~S_IFMT; mode |= S_IFCHR; } else if (fileType == FILE_TYPE_DISK) { mode &= ~S_IFMT; mode |= S_IFBLK; } statPtr->st_dev = (dev_t) dev; statPtr->st_ino = inode; statPtr->st_mode = mode; statPtr->st_nlink = nlink; statPtr->st_uid = 0; |
︙ | ︙ | |||
2516 2517 2518 2519 2520 2521 2522 | * *--------------------------------------------------------------------------- */ int TclpObjNormalizePath( TCL_UNUSED(Tcl_Interp *), | | | | 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 | * *--------------------------------------------------------------------------- */ int TclpObjNormalizePath( TCL_UNUSED(Tcl_Interp *), Tcl_Obj *pathPtr, /* An unshared object containing the path to * normalize */ int nextCheckpoint) /* offset to start at in pathPtr */ { char *lastValidPathEnd = NULL; Tcl_DString dsNorm; /* This will hold the normalized string. */ char *path, *currentPathEndPosition; Tcl_Obj *temp = NULL; int isDrive = 1; Tcl_DString ds; /* Some workspace. */ |
︙ | ︙ | |||
2866 2867 2868 2869 2870 2871 2872 | /* * Path of form /foo/bar which is a path in the root directory of the * current volume. */ const char *drive = TclGetString(useThisCwd); | | | 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 | /* * Path of form /foo/bar which is a path in the root directory of the * current volume. */ const char *drive = TclGetString(useThisCwd); absolutePath = Tcl_NewStringObj(drive,2); Tcl_AppendToObj(absolutePath, path, TCL_INDEX_NONE); Tcl_IncrRefCount(absolutePath); /* * We have a refCount on the cwd. */ } else { |
︙ | ︙ | |||
2968 2969 2970 2971 2972 2973 2974 | /* * Certain native path representations on Windows have this special prefix * to indicate that they are to be treated specially. For example * extremely long paths, or symlinks. */ if (*copy == '\\') { | | | | | 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 | /* * Certain native path representations on Windows have this special prefix * to indicate that they are to be treated specially. For example * extremely long paths, or symlinks. */ if (*copy == '\\') { if (0 == strncmp(copy,"\\??\\",4)) { copy += 4; len -= 4; } else if (0 == strncmp(copy,"\\\\?\\",4)) { copy += 4; len -= 4; } } /* * Ensure we are using forward slashes only. */ for (p = copy; *p != '\0'; p++) { if (*p == '\\') { *p = '/'; } } objPtr = Tcl_NewStringObj(copy,len); Tcl_DStringFree(&ds); return objPtr; } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
3253 3254 3255 3256 3257 3258 3259 | /* *--------------------------------------------------------------------------- * * TclWinFileOwned -- * * Returns 1 if the specified file exists and is owned by the current | | | | 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 | /* *--------------------------------------------------------------------------- * * TclWinFileOwned -- * * Returns 1 if the specified file exists and is owned by the current * user and 0 otherwise. Like the Unix case, the check is made using * the real process SID, not the effective (impersonation) one. * *--------------------------------------------------------------------------- */ int TclWinFileOwned( Tcl_Obj *pathPtr) /* File whose ownership is to be checked */ |
︙ | ︙ | |||
3276 3277 3278 3279 3280 3281 3282 | int owned = 0; native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr); if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT, OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL, &secd) != ERROR_SUCCESS) { | | | | | | | | | | | | | | | | | 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 | int owned = 0; native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr); if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT, OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL, &secd) != ERROR_SUCCESS) { /* * Either not a file, or we do not have access to it in which case we * are in all likelihood not the owner. */ return 0; } /* * Getting the current process SID is a multi-step process. We make the * assumption that if a call fails, this process is so underprivileged it * could not possibly own anything. Normally a process can *always* look * up its own token. */ if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) { /* * Find out how big the buffer needs to be. */ bufsz = 0; GetTokenInformation(token, TokenUser, NULL, 0, &bufsz); if (bufsz) { buf = (LPBYTE)Tcl_Alloc(bufsz); if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) { owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid); } } CloseHandle(token); } /* * Free allocations and be done. */ if (secd) { LocalFree(secd); /* Also frees ownerSid */ } if (buf) { Tcl_Free(buf); } return (owned != 0); /* Convert non-0 to 1 */ } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinInit.c.
︙ | ︙ | |||
512 513 514 515 516 517 518 | if (ptr != NULL) { Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE); } if (Tcl_DStringLength(&ds) > 0) { Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY); } else { | | | | | | | | | | | 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 | if (ptr != NULL) { Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE); } if (Tcl_DStringLength(&ds) > 0) { Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY); } else { /* None of HOME, HOMEDRIVE, HOMEPATH exists. Try USERPROFILE */ ptr = Tcl_GetVar2(interp, "env", "USERPROFILE", TCL_GLOBAL_ONLY); if (ptr != NULL && ptr[0]) { Tcl_SetVar2(interp, "env", "HOME", ptr, TCL_GLOBAL_ONLY); } else { /* Last resort */ Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); } } } /* * Initialize the user name from the environment first, since this is much * faster than asking the system. * Note: cchUserNameLen is number of characters including nul terminator. */ ptr = TclpGetUserName(&ds); Tcl_SetVar2(interp, "tcl_platform", "user", ptr ? ptr : "", TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); /* * Define what the platform PATH separator is. [TIP #315] */ Tcl_SetVar2(interp, "tcl_platform","pathSeparator", ";", TCL_GLOBAL_ONLY); } /* *---------------------------------------------------------------------- * * TclpFindVariable -- * |
︙ | ︙ | |||
566 567 568 569 570 571 572 | *---------------------------------------------------------------------- */ Tcl_Size TclpFindVariable( const char *name, /* Name of desired environment variable * (UTF-8). */ | | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 | *---------------------------------------------------------------------- */ Tcl_Size TclpFindVariable( const char *name, /* Name of desired environment variable * (UTF-8). */ Tcl_Size *lengthPtr) /* Used to return length of name (for * successful searches) or number of non-NULL * entries in environ (for unsuccessful * searches). */ { Tcl_Size i, length, result = TCL_INDEX_NONE; const WCHAR *env; const char *p1, *p2; |
︙ | ︙ |
Changes to win/tclWinInt.h.
︙ | ︙ | |||
47 48 49 50 51 52 53 | char *channelName, int permissions); MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const WCHAR *name, DWORD access); MODULE_SCOPE int TclWinSymLinkCopyDirectory(const WCHAR *LinkOriginal, const WCHAR *LinkCopy); MODULE_SCOPE int TclWinSymLinkDelete(const WCHAR *LinkOriginal, int linkOnly); | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | char *channelName, int permissions); MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const WCHAR *name, DWORD access); MODULE_SCOPE int TclWinSymLinkCopyDirectory(const WCHAR *LinkOriginal, const WCHAR *LinkCopy); MODULE_SCOPE int TclWinSymLinkDelete(const WCHAR *LinkOriginal, int linkOnly); MODULE_SCOPE int TclWinFileOwned(Tcl_Obj *); MODULE_SCOPE void TclWinGenerateChannelName(char channelName[], const char *channelTypeName, void *channelImpl); MODULE_SCOPE const char*TclpGetUserName(Tcl_DString *bufferPtr); /* Needed by tclWinFile.c and tclWinFCmd.c */ #ifndef FILE_ATTRIBUTE_REPARSE_POINT #define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400 |
︙ | ︙ |
Changes to win/tclWinLoad.c.
︙ | ︙ | |||
86 87 88 89 90 91 92 | * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; | | | | | | | | | | | | | | | | | | 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 | * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; /* * Remember the first error on load attempt to be used if the * second load attempt below also fails. */ firstError = (nativeName == NULL) ? ERROR_MOD_NOT_FOUND : GetLastError(); Tcl_DStringInit(&ds); nativeName = Tcl_UtfToWCharDString(TclGetString(pathPtr), TCL_INDEX_NONE, &ds); hInstance = LoadLibraryExW(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); } if (hInstance == NULL) { DWORD lastError; Tcl_Obj *errMsg; /* * We choose to only use the error from the second call if the first * call failed due to the file not being found. Else stick to the * first error for reporting purposes. */ if (firstError == ERROR_MOD_NOT_FOUND || firstError == ERROR_DLL_NOT_FOUND) { lastError = GetLastError(); } else { lastError = firstError; } errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", TclGetString(pathPtr)); /* * Check for possible DLL errors. This doesn't work quite right, * because Windows seems to only return ERROR_MOD_NOT_FOUND for just |
︙ | ︙ | |||
153 154 155 156 157 158 159 | " is damaged", TCL_INDEX_NONE); break; case ERROR_DLL_INIT_FAILED: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", (char *)NULL); Tcl_AppendToObj(errMsg, "the library initialization" " routine failed", TCL_INDEX_NONE); break; | | | | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | " is damaged", TCL_INDEX_NONE); break; case ERROR_DLL_INIT_FAILED: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", (char *)NULL); Tcl_AppendToObj(errMsg, "the library initialization" " routine failed", TCL_INDEX_NONE); break; case ERROR_BAD_EXE_FORMAT: Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", (char *)NULL); Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", TCL_INDEX_NONE); break; default: Tcl_WinConvertError(lastError); Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), TCL_INDEX_NONE); } Tcl_SetObjResult(interp, errMsg); } return TCL_ERROR; } |
︙ | ︙ |
Changes to win/tclWinNotify.c.
︙ | ︙ | |||
144 145 146 147 148 149 150 | * May dispose of the notifier window and class. * *---------------------------------------------------------------------- */ void TclpFinalizeNotifier( | | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 | * May dispose of the notifier window and class. * *---------------------------------------------------------------------- */ void TclpFinalizeNotifier( void *clientData) /* Pointer to notifier data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; /* * Only finalize the notifier if a notifier was installed in the current * thread; there is a route in which this is not guaranteed to be true * (when tclWin32Dll.c:DllMain() is called with the flag |
︙ | ︙ | |||
214 215 216 217 218 219 220 | * isn't already one pending. * *---------------------------------------------------------------------- */ void TclpAlertNotifier( | | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 | * isn't already one pending. * *---------------------------------------------------------------------- */ void TclpAlertNotifier( void *clientData) /* Pointer to thread data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; /* * Note that we do not need to lock around access to the hwnd because the * race condition has no effect since any race condition implies that the * notifier thread is already awake. |
︙ | ︙ | |||
260 261 262 263 264 265 266 | * Replaces any previous timer. * *---------------------------------------------------------------------- */ void TclpSetTimer( | | | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 | * Replaces any previous timer. * *---------------------------------------------------------------------- */ void TclpSetTimer( const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); UINT timeout; /* * We only need to set up an interval timer if we're being called from an * external event loop. If we don't have a window handle then we just |
︙ | ︙ | |||
366 367 368 369 370 371 372 | *---------------------------------------------------------------------- */ int TclAsyncNotifier( TCL_UNUSED(int), /* Signal number. */ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */ | | | | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 | *---------------------------------------------------------------------- */ int TclAsyncNotifier( TCL_UNUSED(int), /* Signal number. */ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */ TCL_UNUSED(void *), /* Notifier data. */ TCL_UNUSED(int *), /* Flag to mark. */ TCL_UNUSED(int)) /* Value of mark. */ { return 0; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
460 461 462 463 464 465 466 | * Dispatches a message to a window procedure, which could do anything. * *---------------------------------------------------------------------- */ int TclpWaitForEvent( | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 | * Dispatches a message to a window procedure, which could do anything. * *---------------------------------------------------------------------- */ int TclpWaitForEvent( const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); MSG msg; DWORD timeout, result; int status; /* |
︙ | ︙ |
Changes to win/tclWinPipe.c.
︙ | ︙ | |||
199 200 201 202 203 204 205 | * This structure describes the channel type structure for command pipe based * I/O. */ static const Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 | * This structure describes the channel type structure for command pipe based * I/O. */ static const Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ NULL, /* Close proc. */ PipeInputProc, /* Input proc. */ PipeOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ PipeWatchProc, /* Set up notifier to watch the channel. */ PipeGetHandleProc, /* Get an OS handle from channel. */ |
︙ | ︙ | |||
912 913 914 915 916 917 918 | int TclpCreateProcess( Tcl_Interp *interp, /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ | | | 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 | int TclpCreateProcess( Tcl_Interp *interp, /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ size_t argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings. argv[0] contains * the name of the executable converted to * native format (using the * Tcl_TranslateFileName call). Additional * arguments have not been converted. */ TclFile inputFile, /* If non-NULL, gives the file to use as input * for the child process. If inputFile file is |
︙ | ︙ | |||
1533 1534 1535 1536 1537 1538 1539 | return special; } static void BuildCommandLine( const char *executable, /* Full path of executable (including * extension). Replacement for argv[0]. */ | | | 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 | return special; } static void BuildCommandLine( const char *executable, /* Full path of executable (including * extension). Replacement for argv[0]. */ size_t argc, /* Number of arguments. */ const char **argv, /* Argument strings in UTF. */ Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the * command line (WCHAR). */ { const char *arg, *start, *special, *bspos; int quote = 0; size_t i; |
︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int PipeBlockModeProc( | | | 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int PipeBlockModeProc( void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; /* * Pipes on Windows can not be switched between blocking and nonblocking, |
︙ | ︙ | |||
1989 1990 1991 1992 1993 1994 1995 | * Closes the physical channel. * *---------------------------------------------------------------------- */ static int PipeClose2Proc( | | | 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 | * Closes the physical channel. * *---------------------------------------------------------------------- */ static int PipeClose2Proc( void *instanceData, /* Pointer to PipeInfo structure. */ Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { PipeInfo *pipePtr = (PipeInfo *) instanceData; Tcl_Channel errChan; int errorCode, result; PipeInfo *infoPtr, **nextPtrPtr; |
︙ | ︙ | |||
2160 2161 2162 2163 2164 2165 2166 | * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int PipeInputProc( | | | 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 | * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int PipeInputProc( void *instanceData, /* Pipe state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ int *errorCode) /* Where to store error code. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; WinFile *filePtr = (WinFile*) infoPtr->readFile; |
︙ | ︙ | |||
2254 2255 2256 2257 2258 2259 2260 | * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc( | | | 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 | * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc( void *instanceData, /* Pipe state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; WinFile *filePtr = (WinFile*) infoPtr->writeFile; DWORD bytesWritten, timeout; |
︙ | ︙ | |||
2402 2403 2404 2405 2406 2407 2408 | mask = 0; if ((infoPtr->watchMask & TCL_WRITABLE) && (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) { mask = TCL_WRITABLE; } | | | 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 | mask = 0; if ((infoPtr->watchMask & TCL_WRITABLE) && (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) { mask = TCL_WRITABLE; } if ((infoPtr->watchMask & TCL_READABLE) && (WaitForRead(infoPtr,0) >= 0)) { if (infoPtr->readFlags & PIPE_EOF) { mask = TCL_READABLE; } else { mask |= TCL_READABLE; } } |
︙ | ︙ | |||
2436 2437 2438 2439 2440 2441 2442 | * None. * *---------------------------------------------------------------------- */ static void PipeWatchProc( | | | 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 | * None. * *---------------------------------------------------------------------- */ static void PipeWatchProc( void *instanceData, /* Pipe state. */ int mask) /* What events to watch for, OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { PipeInfo **nextPtrPtr, *ptr; PipeInfo *infoPtr = (PipeInfo *) instanceData; int oldMask = infoPtr->watchMask; |
︙ | ︙ | |||
2498 2499 2500 2501 2502 2503 2504 | * None. * *---------------------------------------------------------------------- */ static int PipeGetHandleProc( | | | | 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 | * None. * *---------------------------------------------------------------------- */ static int PipeGetHandleProc( void *instanceData, /* The pipe state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ void **handlePtr) /* Where to store the handle. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; WinFile *filePtr; if (direction == TCL_READABLE && infoPtr->readFile) { filePtr = (WinFile*) infoPtr->readFile; *handlePtr = (void *)filePtr->handle; |
︙ | ︙ |
Changes to win/tclWinPort.h.
︙ | ︙ | |||
508 509 510 511 512 513 514 | #endif /* * The following defines wrap the system memory allocation routines for * use by tclAlloc.c. */ | | | | | | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 | #endif /* * The following defines wrap the system memory allocation routines for * use by tclAlloc.c. */ #define TclpSysAlloc(size) ((void*)HeapAlloc(GetProcessHeap(), \ 0, size)) #define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \ 0, (HGLOBAL)ptr)) #define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \ 0, (LPVOID)ptr, size)) /* This type is not defined in the Windows headers */ #define socklen_t int /* * The following macros have trivial definitions, allowing generic code to * address platform-specific issues. |
︙ | ︙ |
Changes to win/tclWinReg.c.
︙ | ︙ | |||
84 85 86 87 88 89 90 | "dword_big_endian", "link", "multi_sz", "resource_list", NULL }; static DWORD lastType = REG_RESOURCE_LIST; #if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 | | < | < | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | "dword_big_endian", "link", "multi_sz", "resource_list", NULL }; static DWORD lastType = REG_RESOURCE_LIST; #if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 # define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) # define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) # else # define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString # define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString # endif #ifndef Tcl_Size # define Tcl_Size int #endif |
︙ | ︙ | |||
291 292 293 294 295 296 297 | * None. * *---------------------------------------------------------------------- */ static int RegistryObjCmd( | | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 | * None. * *---------------------------------------------------------------------- */ static int RegistryObjCmd( void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { Tcl_Size n = 1, argc; int index; REGSAM mode = 0; const char *errString = NULL; |
︙ | ︙ | |||
933 934 935 936 937 938 939 | /* * Enumerate the values under the given subkey until we get an error, * indicating the end of the list. Note that we need to reset size after * each iteration because RegEnumValue smashes the old value. */ size = MAX_KEY_LENGTH; | | | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 | /* * Enumerate the values under the given subkey until we get an error, * indicating the end of the list. Note that we need to reset size after * each iteration because RegEnumValue smashes the old value. */ size = MAX_KEY_LENGTH; while (RegEnumValueW(key,index, (WCHAR *)Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { Tcl_DStringInit(&ds); Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&buffer), size, &ds); name = Tcl_DStringValue(&ds); if (!pattern || Tcl_StringMatch(name, pattern)) { result = Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); |
︙ | ︙ | |||
1427 1428 1429 1430 1431 1432 1433 | * *---------------------------------------------------------------------- */ static int BroadcastValue( Tcl_Interp *interp, /* Current interpreter. */ | | | 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 | * *---------------------------------------------------------------------- */ static int BroadcastValue( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { LRESULT result; DWORD_PTR sendResult; int timeout = 3000; Tcl_Size len; const char *str; |
︙ | ︙ |
Changes to win/tclWinSerial.c.
︙ | ︙ | |||
200 201 202 203 204 205 206 | * This structure describes the channel type structure for command serial * based IO. */ static const Tcl_ChannelType serialChannelType = { "serial", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ | | | | 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 | * This structure describes the channel type structure for command serial * based IO. */ static const Tcl_ChannelType serialChannelType = { "serial", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ NULL, /* Close proc. */ SerialInputProc, /* Input proc. */ SerialOutputProc, /* Output proc. */ NULL, /* Seek proc. */ SerialSetOptionProc, /* Set option proc. */ SerialGetOptionProc, /* Get option proc. */ SerialWatchProc, /* Set up notifier to watch the channel. */ SerialGetHandleProc, /* Get an OS handle from channel. */ SerialCloseProc, /* close2proc. */ SerialBlockProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc */ SerialThreadActionProc, /* thread action proc */ NULL /* truncate */ }; /* *---------------------------------------------------------------------- * * SerialInit -- * |
︙ | ︙ | |||
850 851 852 853 854 855 856 | * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int SerialInputProc( | | | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 | * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int SerialInputProc( void *instanceData, /* Serial state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ int *errorCode) /* Where to store error code. */ { SerialInfo *infoPtr = (SerialInfo *) instanceData; DWORD bytesRead = 0; |
︙ | ︙ | |||
957 958 959 960 961 962 963 | * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int SerialOutputProc( | | | 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 | * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int SerialOutputProc( void *instanceData, /* Serial state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ { SerialInfo *infoPtr = (SerialInfo *) instanceData; DWORD bytesWritten, timeout; |
︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 | * None. * *---------------------------------------------------------------------- */ static void SerialWatchProc( | | | 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 | * None. * *---------------------------------------------------------------------- */ static void SerialWatchProc( void *instanceData, /* Serial state. */ int mask) /* What events to watch for, OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { SerialInfo **nextPtrPtr, *ptr; SerialInfo *infoPtr = (SerialInfo *) instanceData; int oldMask = infoPtr->watchMask; |
︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 | * None. * *---------------------------------------------------------------------- */ static int SerialGetHandleProc( | | | | 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 | * None. * *---------------------------------------------------------------------- */ static int SerialGetHandleProc( void *instanceData, /* The serial state. */ TCL_UNUSED(int) /*direction*/, void **handlePtr) /* Where to store the handle. */ { SerialInfo *infoPtr = (SerialInfo *) instanceData; *handlePtr = (void *)infoPtr->handle; return TCL_OK; } |
︙ | ︙ | |||
1606 1607 1608 1609 1610 1611 1612 | * May modify an option on a device. * *---------------------------------------------------------------------- */ static int SerialSetOptionProc( | | | 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 | * May modify an option on a device. * *---------------------------------------------------------------------- */ static int SerialSetOptionProc( void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ { SerialInfo *infoPtr; DCB dcb; BOOL result, flag; |
︙ | ︙ | |||
2025 2026 2027 2028 2029 2030 2031 | * reused at any time subsequent to the call. * *---------------------------------------------------------------------- */ static int SerialGetOptionProc( | | | 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 | * reused at any time subsequent to the call. * *---------------------------------------------------------------------- */ static int SerialGetOptionProc( void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ { SerialInfo *infoPtr; DCB dcb; size_t len; |
︙ | ︙ |
Changes to win/tclWinSock.c.
︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 | TcpState *statePtr = (TcpState *)instanceData; char host[NI_MAXHOST], port[NI_MAXSERV]; SOCKET sock; size_t len = 0; int reverseDNS = 0; #define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" #define HAVE_OPTION(option) \ | | | 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 | TcpState *statePtr = (TcpState *)instanceData; char host[NI_MAXHOST], port[NI_MAXSERV]; SOCKET sock; size_t len = 0; int reverseDNS = 0; #define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" #define HAVE_OPTION(option) \ ((len > 1) && (optionName[1] == option[1]) && \ (strncmp(optionName, option, len) == 0)) /* * Go one step in async connect * * If any error is thrown save it as background error to report eventually * below. |
︙ | ︙ | |||
2646 2647 2648 2649 2650 2651 2652 | if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) { if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { /* * Do one step and save eventual connect error */ SetEvent(tsdPtr->socketListLock); | | | 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 | if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) { if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { /* * Do one step and save eventual connect error */ SetEvent(tsdPtr->socketListLock); WaitForConnect(statePtr,NULL); } else { /* * No async connect reenter pending. Just clear event. */ CLEAR_BITS(statePtr->readyEvents, FD_CONNECT); SetEvent(tsdPtr->socketListLock); |
︙ | ︙ |
Changes to win/tclWinThrd.c.
︙ | ︙ | |||
214 215 216 217 218 219 220 | winThreadPtr = (WinThread *)Tcl_Alloc(sizeof(WinThread)); winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc; winThreadPtr->lpParameter = clientData; winThreadPtr->fpControl = _controlfp(0, 0); EnterCriticalSection(&joinLock); | | | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | winThreadPtr = (WinThread *)Tcl_Alloc(sizeof(WinThread)); winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc; winThreadPtr->lpParameter = clientData; winThreadPtr->fpControl = _controlfp(0, 0); EnterCriticalSection(&joinLock); *idPtr = 0; /* must initialize as Tcl_Thread is a pointer and * on WIN64 sizeof void* != sizeof unsigned */ #if defined(_MSC_VER) || defined(__MSVCRT__) tHandle = (HANDLE) _beginthreadex(NULL, (unsigned)stackSize, (Tcl_ThreadCreateProc*) TclWinThreadStart, winThreadPtr, 0, (unsigned *)idPtr); #else tHandle = CreateThread(NULL, (DWORD)stackSize, |
︙ | ︙ |