Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | merge with trunk |
---|---|
Timelines: | family | ancestors | descendants | both | wtf-8-experiment |
Files: | files | file ages | folders |
SHA1: |
d78a1dbb7e89f02cc68e669101066e9c |
User & Date: | chw 2020-07-25 19:24:49.155 |
Context
2020-07-28
| ||
04:57 | merge with trunk check-in: ac0d74ae78 user: chw tags: wtf-8-experiment | |
2020-07-25
| ||
19:24 | merge with trunk check-in: d78a1dbb7e user: chw tags: wtf-8-experiment | |
19:24 | add selected tk upstream changes check-in: 0826c6af99 user: chw tags: trunk | |
05:19 | merge with trunk check-in: d692415492 user: chw tags: wtf-8-experiment | |
Changes
Changes to jni/sdl2tk/library/console.tcl.
︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 | variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used if {$inPlugin} { set defaultPrompt {subst {[history nextid] % }} } else { set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }} } } # simple compat function for tkcon code added for this console interp alias {} EvalAttached {} consoleinterp eval # ::tk::ConsoleInit -- # This procedure constructs and configures the console windows. | > > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used if {$inPlugin} { set defaultPrompt {subst {[history nextid] % }} } else { set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }} } if {!$useFontchooser} { set useFontchooser [info exists ::auto_index(::tk::fontchooser)] } } # simple compat function for tkcon code added for this console interp alias {} EvalAttached {} consoleinterp eval # ::tk::ConsoleInit -- # This procedure constructs and configures the console windows. |
︙ | ︙ | |||
116 117 118 119 120 121 122 | [list ::tk::console::FontchooserVisibility $index] ::tk::console::FontchooserVisibility $index } else { AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \ -command [list ::tk::console::FontchooserToggle] } bind Console <FocusIn> [list ::tk::console::FontchooserFocus %W 1] | > | > | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | [list ::tk::console::FontchooserVisibility $index] ::tk::console::FontchooserVisibility $index } else { AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \ -command [list ::tk::console::FontchooserToggle] } bind Console <FocusIn> [list ::tk::console::FontchooserFocus %W 1] if {[tk windowingsystem] ne "x11"} { bind Console <FocusOut> [list ::tk::console::FontchooserFocus %W 0] } } AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \ -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>} AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \ -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>} AmpMenuArgs .menubar.edit add command -label [mc "Fit To Screen Width"] \ -command {event generate .console <<Console_FitScreenWidth>>} |
︙ | ︙ | |||
765 766 767 768 769 770 771 | tk fontchooser hide } else { tk fontchooser show } } proc ::tk::console::FontchooserVisibility {index} { if {[tk fontchooser configure -visible]} { | | > | > > > > > > | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 | tk fontchooser hide } else { tk fontchooser show } } proc ::tk::console::FontchooserVisibility {index} { if {[tk fontchooser configure -visible]} { .menubar.edit entryconfigure $index \ -label [::tk::msgcat::mc "Hide Fonts"] } else { .menubar.edit entryconfigure $index \ -label [::tk::msgcat::mc "Show Fonts"] } } proc ::tk::console::FontchooserFocus {w isFocusIn} { if {[tk windowingsystem] eq "x11"} { tk fontchooser configure -parent $w \ -command [namespace code [list FontchooserApply]] return } if {$isFocusIn} { tk fontchooser configure -parent $w -font TkConsoleFont \ -command [namespace code [list FontchooserApply]] } else { tk fontchooser configure -parent $w -font {} -command {} } } |
︙ | ︙ |
Changes to jni/sdl2tk/library/fontchooser.tcl.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. namespace eval ::tk::fontchooser { variable S set S(W) .__tk__fontchooser | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. namespace eval ::tk::fontchooser { variable S set S(W) .__tk__fontchooser set S(fonts) [lsort -dictionary -nocase -unique [font families]] set S(styles) [list \ [::msgcat::mc "Regular"] \ [::msgcat::mc "Italic"] \ [::msgcat::mc "Bold"] \ [::msgcat::mc "Bold Italic"] \ ] |
︙ | ︙ | |||
61 62 63 64 65 66 67 | proc ::tk::fontchooser::Show {} { variable S if {![winfo exists $S(W)]} { Create wm transient $S(W) [winfo toplevel $S(-parent)] tk::PlaceWindow $S(W) widget $S(-parent) } | | | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | proc ::tk::fontchooser::Show {} { variable S if {![winfo exists $S(W)]} { Create wm transient $S(W) [winfo toplevel $S(-parent)] tk::PlaceWindow $S(W) widget $S(-parent) } set S(fonts) [lsort -dictionary -nocase -unique [font families]] set S(fonts,lcase) {} foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]} wm deiconify $S(W) } proc ::tk::fontchooser::Hide {} { variable S |
︙ | ︙ |
Changes to jni/tcl/generic/tclInt.h.
︙ | ︙ | |||
1800 1801 1802 1803 1804 1805 1806 | Namespace *globalNsPtr; /* The interpreter's global namespace. */ Tcl_HashTable *hiddenCmdTablePtr; /* Hash table used by tclBasic.c to keep track * of hidden commands on a per-interp * basis. */ ClientData interpInfo; /* Information used by tclInterp.c to keep | | | 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 | Namespace *globalNsPtr; /* The interpreter's global namespace. */ Tcl_HashTable *hiddenCmdTablePtr; /* Hash table used by tclBasic.c to keep track * of hidden commands on a per-interp * basis. */ ClientData interpInfo; /* Information used by tclInterp.c to keep * track of parent/child interps on a * per-interp basis. */ union { void (*optimizer)(void *envPtr); Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The * unused space in interp was repurposed for * pluggable bytecode optimizers. The core * contains one optimizer, which can be |
︙ | ︙ | |||
2078 2079 2080 2081 2082 2083 2084 | /* * The thread-specific data ekeko: cache pointers or values that * (a) do not change during the thread's lifetime * (b) require access to TSD to determine at runtime * (c) are accessed very often (e.g., at each command call) * * Note that these are the same for all interps in the same thread. They | | | 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 | /* * The thread-specific data ekeko: cache pointers or values that * (a) do not change during the thread's lifetime * (b) require access to TSD to determine at runtime * (c) are accessed very often (e.g., at each command call) * * Note that these are the same for all interps in the same thread. They * just have to be initialised for the thread's parent interp, children * inherit the value. * * They are used by the macros defined below. */ AllocCache *allocCache; void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData |
︙ | ︙ | |||
2596 2597 2598 2599 2600 2601 2602 | typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); /* * A ProcessGlobalValue struct exists for each internal value in Tcl that is * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of | | | | | | | | | | 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 | typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); /* * A ProcessGlobalValue struct exists for each internal value in Tcl that is * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of * the value, and the gobal value is kept as a counted string, with epoch and * mutex control. Each ProcessGlobalValue struct should be a static variable in * some file. */ typedef struct ProcessGlobalValue { int epoch; /* Epoch counter to detect changes in the * global value. */ int numBytes; /* Length of the global string. */ char *value; /* The global string value. */ Tcl_Encoding encoding; /* system encoding when global string was * initialized. */ TclInitProcessGlobalValueProc *proc; /* A procedure to initialize the global string * copy when a "get" request comes in before * any "set" request has been received. */ Tcl_Mutex mutex; /* Enforce orderly access from multiple * threads. */ Tcl_ThreadDataKey key; /* Key for per-thread data holding the * (Tcl_Obj) copy for each thread. */ } ProcessGlobalValue; |
︙ | ︙ | |||
3099 3100 3101 3102 3103 3104 3105 | MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); | | | | 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 | MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); MODULE_SCOPE void TclpGlobalLock(void); MODULE_SCOPE void TclpGlobalUnlock(void); MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail); MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr); MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, |
︙ | ︙ | |||
3226 3227 3228 3229 3230 3231 3232 | # endif #endif MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); | | | | 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 | # endif #endif MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length); #if TCL_UTF_MAX > 3 MODULE_SCOPE int TclCollapseSurrogatePair(Tcl_Token *tokenPtr, int *numReadPtr, char *buffer); #define TclUCS4ToUpper(ch) Tcl_UniCharToUpper((ch)) |
︙ | ︙ |
Changes to jni/tcl/generic/tclThread.c.
︙ | ︙ | |||
137 138 139 140 141 142 143 | *---------------------------------------------------------------------- * * RememberSyncObject * * Keep a list of (mutexes/condition variable/data key) used during * finalization. * | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | *---------------------------------------------------------------------- * * RememberSyncObject * * Keep a list of (mutexes/condition variable/data key) used during * finalization. * * Assume global lock is held. * * Results: * None. * * Side effects: * Add to the appropriate list. * |
︙ | ︙ | |||
198 199 200 201 202 203 204 | /* *---------------------------------------------------------------------- * * ForgetSyncObject * * Remove a single object from the list. | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 | /* *---------------------------------------------------------------------- * * ForgetSyncObject * * Remove a single object from the list. * Assume global lock is held. * * Results: * None. * * Side effects: * Remove from the appropriate list. * |
︙ | ︙ | |||
230 231 232 233 234 235 236 | /* *---------------------------------------------------------------------- * * TclRememberMutex * * Keep a list of mutexes used during finalization. | | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 | /* *---------------------------------------------------------------------- * * TclRememberMutex * * Keep a list of mutexes used during finalization. * Assume global lock is held. * * Results: * None. * * Side effects: * Add to the mutex list. * |
︙ | ︙ | |||
272 273 274 275 276 277 278 | void Tcl_MutexFinalize( Tcl_Mutex *mutexPtr) { #ifdef TCL_THREADS TclpFinalizeMutex(mutexPtr); #endif | | | | | 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 | void Tcl_MutexFinalize( Tcl_Mutex *mutexPtr) { #ifdef TCL_THREADS TclpFinalizeMutex(mutexPtr); #endif TclpGlobalLock(); ForgetSyncObject(mutexPtr, &mutexRecord); TclpGlobalUnlock(); } /* *---------------------------------------------------------------------- * * TclRememberCondition * * Keep a list of condition variables used during finalization. * Assume global lock is held. * * Results: * None. * * Side effects: * Add to the condition variable list. * |
︙ | ︙ | |||
325 326 327 328 329 330 331 | void Tcl_ConditionFinalize( Tcl_Condition *condPtr) { #ifdef TCL_THREADS TclpFinalizeCondition(condPtr); #endif | | | | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 | void Tcl_ConditionFinalize( Tcl_Condition *condPtr) { #ifdef TCL_THREADS TclpFinalizeCondition(condPtr); #endif TclpGlobalLock(); ForgetSyncObject(condPtr, &condRecord); TclpGlobalUnlock(); } /* *---------------------------------------------------------------------- * * TclFinalizeThreadData -- * |
︙ | ︙ | |||
389 390 391 392 393 394 395 | int i; void *blockPtr; Tcl_ThreadDataKey *keyPtr; #ifdef TCL_THREADS Tcl_Mutex *mutexPtr; Tcl_Condition *condPtr; | | | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 | int i; void *blockPtr; Tcl_ThreadDataKey *keyPtr; #ifdef TCL_THREADS Tcl_Mutex *mutexPtr; Tcl_Condition *condPtr; TclpGlobalLock(); #endif /* * If we're running unthreaded, the TSD blocks are simply stored inside * their thread data keys. Free them here. */ |
︙ | ︙ | |||
411 412 413 414 415 416 417 | keyRecord.list = NULL; } keyRecord.max = 0; keyRecord.num = 0; #ifdef TCL_THREADS /* | | | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 | keyRecord.list = NULL; } keyRecord.max = 0; keyRecord.num = 0; #ifdef TCL_THREADS /* * Call thread storage global cleanup. */ TclFinalizeThreadStorage(); for (i=0 ; i<mutexRecord.num ; i++) { mutexPtr = (Tcl_Mutex *)mutexRecord.list[i]; if (mutexPtr != NULL) { |
︙ | ︙ | |||
442 443 444 445 446 447 448 | if (condRecord.list != NULL) { ckfree(condRecord.list); condRecord.list = NULL; } condRecord.max = 0; condRecord.num = 0; | | | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | if (condRecord.list != NULL) { ckfree(condRecord.list); condRecord.list = NULL; } condRecord.max = 0; condRecord.num = 0; TclpGlobalUnlock(); #endif /* TCL_THREADS */ } /* *---------------------------------------------------------------------- * * Tcl_ExitThread -- |
︙ | ︙ |
Changes to jni/tcl/generic/tclThreadStorage.c.
︙ | ︙ | |||
23 24 25 26 27 28 29 | * it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into * the table of TSD values. We don't use more than 1 platform-specific TSD * slot, because there is a hard limit on the number of TSD slots. Valid key * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey. */ /* | | | | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | * it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into * the table of TSD values. We don't use more than 1 platform-specific TSD * slot, because there is a hard limit on the number of TSD slots. Valid key * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey. */ /* * The global collection of information about TSDs. This is shared across the * whole process, and includes the mutex used to protect it. */ static struct { void *key; /* Key into the system TSD structure. The * collection of Tcl TSD values for a * particular thread will hang off the * back-end of this. */ sig_atomic_t counter; /* The number of different Tcl TSDs used * across *all* threads. This is a strictly * increasing value. */ Tcl_Mutex mutex; /* Protection for the rest of this structure, * which holds per-process data. */ } tsdGlobal = { NULL, 0, NULL }; /* * The type of the data held per thread in a system TSD. */ typedef struct { ClientData *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. */ typedef union { volatile sig_atomic_t offset; /* The type is really an offset into the * thread-local table of TSDs, which is this * field. */ void *ptr; /* For alignment purposes only. Not actually * accessed through this. */ } TSDUnion; |
︙ | ︙ | |||
185 186 187 188 189 190 191 | *---------------------------------------------------------------------- */ void * TclThreadStorageKeyGet( Tcl_ThreadDataKey *dataKeyPtr) { | | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 | *---------------------------------------------------------------------- */ void * TclThreadStorageKeyGet( Tcl_ThreadDataKey *dataKeyPtr) { TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key); ClientData resultPtr = NULL; TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr; sig_atomic_t offset = keyPtr->offset; if ((tsdTablePtr != NULL) && (offset > 0) && (offset < tsdTablePtr->allocated)) { resultPtr = tsdTablePtr->tablePtr[offset]; |
︙ | ︙ | |||
219 220 221 222 223 224 225 | */ void TclThreadStorageKeySet( Tcl_ThreadDataKey *dataKeyPtr, void *value) { | | | | | | | 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 254 255 256 257 258 | */ void TclThreadStorageKeySet( Tcl_ThreadDataKey *dataKeyPtr, void *value) { TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key); TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr; if (tsdTablePtr == NULL) { tsdTablePtr = TSDTableCreate(); TclpThreadSetGlobalTSD(tsdGlobal.key, tsdTablePtr); } /* * Get the lock while we check if this TSD is new or not. Note that this * is the only place where Tcl_ThreadDataKey values are set. We use a * double-checked lock to try to avoid having to grab this lock a lot, * since it is on quite a few critical paths and will only get set once in * each location. */ if (keyPtr->offset == 0) { Tcl_MutexLock(&tsdGlobal.mutex); if (keyPtr->offset == 0) { /* * The Tcl_ThreadDataKey hasn't been used yet. Make a new one. */ keyPtr->offset = ++tsdGlobal.counter; } Tcl_MutexUnlock(&tsdGlobal.mutex); } /* * Check if this is the first time this Tcl_ThreadDataKey has been used * with the current thread. Note that we don't need to hold a lock when * doing this, as we are *definitely* the only point accessing this * tsdTablePtr right now; it's thread-local. |
︙ | ︙ | |||
284 285 286 287 288 289 290 | * *---------------------------------------------------------------------- */ void TclFinalizeThreadDataThread(void) { | | | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | * *---------------------------------------------------------------------- */ void TclFinalizeThreadDataThread(void) { TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key); if (tsdTablePtr != NULL) { TSDTableDelete(tsdTablePtr); TclpThreadSetGlobalTSD(tsdGlobal.key, NULL); } } /* *---------------------------------------------------------------------- * * TclInitializeThreadStorage -- |
︙ | ︙ | |||
312 313 314 315 316 317 318 | * *---------------------------------------------------------------------- */ void TclInitThreadStorage(void) { | | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 | * *---------------------------------------------------------------------- */ void TclInitThreadStorage(void) { tsdGlobal.key = TclpThreadCreateKey(); } /* *---------------------------------------------------------------------- * * TclFinalizeThreadStorage -- * |
︙ | ︙ | |||
335 336 337 338 339 340 341 | * *---------------------------------------------------------------------- */ void TclFinalizeThreadStorage(void) { | | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 | * *---------------------------------------------------------------------- */ void TclFinalizeThreadStorage(void) { TclpThreadDeleteKey(tsdGlobal.key); tsdGlobal.key = NULL; } #else /* !TCL_THREADS */ /* * Stub functions for non-threaded builds */ |
︙ | ︙ |
Changes to jni/tcl/generic/tclUtil.c.
︙ | ︙ | |||
4429 4430 4431 4432 4433 4434 4435 | int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); if (pgvPtr->encoding != current) { /* | | | | 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 | int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); if (pgvPtr->encoding != current) { /* * The system encoding has changed since the global string value * was saved. Convert the global value to be based on the new * system encoding. */ Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); epoch = ++pgvPtr->epoch; |
︙ | ︙ |
Changes to jni/tcl/library/tcltest/tcltest.tcl.
︙ | ︙ | |||
807 808 809 810 811 812 813 | # errors go to stderr by default Option -errfile stderr { Send errors from test runs to the specified file. } AcceptOutFile errorFile trace add variable Option(-errfile) write \ [namespace code {errorChannel $Option(-errfile) ;#}] | | | | | | | | 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 | # errors go to stderr by default Option -errfile stderr { Send errors from test runs to the specified file. } AcceptOutFile errorFile trace add variable Option(-errfile) write \ [namespace code {errorChannel $Option(-errfile) ;#}] proc loadIntoChildInterpreter {child args} { variable Version interp eval $child [package ifneeded tcltest $Version] interp eval $child "tcltest::configure {*}{$args}" interp alias $child ::tcltest::ReportToParent \ {} ::tcltest::ReportedFromChild } proc ReportedFromChild {total passed skipped failed because newfiles} { variable numTests variable skippedBecause variable createdNewFiles incr numTests(Total) $total incr numTests(Passed) $passed incr numTests(Skipped) $skipped incr numTests(Failed) $failed |
︙ | ︙ | |||
2458 2459 2460 2461 2462 2463 2464 | variable originalTclPlatform variable coreModTime FillFilesExisted set testFileName [file tail [info script]] # Hook to handle reporting to a parent interpreter | | | | 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 | variable originalTclPlatform variable coreModTime FillFilesExisted set testFileName [file tail [info script]] # Hook to handle reporting to a parent interpreter if {[llength [info commands [namespace current]::ReportToParent]]} { ReportToParent $numTests(Total) $numTests(Passed) $numTests(Skipped) \ $numTests(Failed) [array get skippedBecause] \ [array get createdNewFiles] set testSingleFile false } # Call the cleanup hook cleanupTestsHook |
︙ | ︙ |
Changes to jni/tcl/tests/chanio.test.
︙ | ︙ | |||
6367 6368 6369 6370 6371 6372 6373 | lappend l [chan eof $f] } -cleanup { chan close $f } -result [list 7 a\rb\rc 7 {} 7 1] test chan-io-50.1 {testing handler deletion} -setup { file delete $path(test1) | | | | | 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 | lappend l [chan eof $f] } -cleanup { chan close $f } -result [list 7 a\rb\rc 7 {} 7 1] test chan-io-50.1 {testing handler deletion} -setup { file delete $path(test1) } -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] testchannelevent $f add readable [namespace code { variable z called testchannelevent $f delete 0 }] variable z not_called update return $z } -cleanup { chan close $f } -result called test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" } -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list delhandler $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] proc delhandler {f i} { variable z lappend z "called delhandler $f $i" testchannelevent $f delete 0 } update string equal $z \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } -cleanup { chan close $f } -result 1 test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" } -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" } |
︙ | ︙ | |||
6430 6431 6432 6433 6434 6435 6436 | } -cleanup { chan close $f } -result 1 test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f | | | 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 | } -cleanup { chan close $f } -result 1 test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f } -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code { if {$u eq "recursive"} { testchannelevent $f delete 0 lappend z "delrecursive deleting recursive" } else { lappend z "delrecursive calling recursive" |
︙ | ︙ | |||
6453 6454 6455 6456 6457 6458 6459 | } -cleanup { chan close $f } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f | | | 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 | } -cleanup { chan close $f } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f } -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f]] testchannelevent $f add readable [namespace code [list del $f]] proc notcalled {f} { variable z lappend z "notcalled was called!! $f" } |
︙ | ︙ | |||
6488 6489 6490 6491 6492 6493 6494 | chan close $f } -result [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f | | | 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 | chan close $f } -result [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f } -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list second $f]] testchannelevent $f add readable [namespace code [list first $f]] proc first {f} { variable u variable z if {$u eq "toplevel"} { |
︙ | ︙ |
Changes to jni/tcl/tests/event.test.
︙ | ︙ | |||
23 24 25 26 27 28 29 | testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] testConstraint exec [llength [info commands exec]] test event-1.1 {Tcl_CreateFileHandler, reading} -setup { testfilehandler close set result "" | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] testConstraint exec [llength [info commands exec]] test event-1.1 {Tcl_CreateFileHandler, reading} -setup { testfilehandler close set result "" } -constraints {testfilehandler nonPortable} -body { testfilehandler create 0 readable off testfilehandler clear 0 testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler fillpartial 0 testfilehandler oneevent lappend result [testfilehandler counts 0] |
︙ | ︙ |
Changes to jni/tcl/tests/http11.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # http11.test -- -*- tcl-*- # # Test HTTP/1.1 features. # # Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import -force ::tcltest::* | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # http11.test -- -*- tcl-*- # # Test HTTP/1.1 features. # # Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import -force ::tcltest::* package require http 2.9 # start the server variable httpd_output proc create_httpd {} { proc httpd_read {chan} { variable httpd_output if {[gets $chan line] != -1} { |
︙ | ︙ |
Changes to jni/tcl/tests/httpPipeline.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # httpPipeline.test # # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # # Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import -force ::tcltest::* | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # httpPipeline.test # # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # # Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace import -force ::tcltest::* package require http 2.9 set sourcedir [file normalize [file dirname [info script]]] source [file join $sourcedir httpTest.tcl] source [file join $sourcedir httpTestScript.tcl] # ------------------------------------------------------------------------------ # (1) Define the test scripts that will be used to generate logs for analysis - |
︙ | ︙ |
Changes to jni/tcl/tests/init.test.
︙ | ︙ | |||
15 16 17 18 19 20 21 | namespace import -force ::tcltest::* } # Clear out any namespaces called test_ns_* catch {namespace delete {*}[namespace children :: test_ns_*]} test init-0.1 {no error on initialization phase (init.tcl)} -setup { | | | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | namespace import -force ::tcltest::* } # Clear out any namespaces called test_ns_* catch {namespace delete {*}[namespace children :: test_ns_*]} test init-0.1 {no error on initialization phase (init.tcl)} -setup { interp create child } -body { child eval { list [set v [info exists ::errorInfo]] \ [if {$v} {set ::errorInfo}] \ [set v [info exists ::errorCode]] \ [if {$v} {set ::errorCode}] } } -cleanup { interp delete child } -result {0 {} 0 {}} # Six cases - white box testing test init-1.1 {auto_qualify - absolute cmd - namespace} { auto_qualify ::foo::bar ::blue } ::foo::bar |
︙ | ︙ | |||
55 56 57 58 59 60 61 | test init-1.7 {auto_qualify - multiples colons 1} { auto_qualify :::foo::::bar ::blue } ::foo::bar test init-1.8 {auto_qualify - multiple colons 2} { auto_qualify :::foo ::bar } foo | | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | test init-1.7 {auto_qualify - multiples colons 1} { auto_qualify :::foo::::bar ::blue } ::foo::bar test init-1.8 {auto_qualify - multiple colons 2} { auto_qualify :::foo ::bar } foo # We use a child interp and auto_reset and double the tests because there is 2 # places where auto_loading occur (before loading the indexes files and after) set testInterp [interp create] tcltest::loadIntoChildInterpreter $testInterp {*}$argv interp eval $testInterp { namespace import -force ::tcltest::* customMatch pairwise {apply {{mode pair} { if {[llength $pair] != 2} {error "need a pair of values to check"} string $mode [lindex $pair 0] [lindex $pair 1] }}} |
︙ | ︙ |
Changes to jni/tcl/tests/io.test.
︙ | ︙ | |||
6714 6715 6716 6717 6718 6719 6720 | lappend l [gets $f] lappend l [tell $f] lappend l [eof $f] close $f set l } [list 7 a\rb\rc 7 {} 7 1] | | | | | 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 | lappend l [gets $f] lappend l [tell $f] lappend l [eof $f] close $f set l } [list 7 a\rb\rc 7 {} 7 1] test io-50.1 {testing handler deletion} {testchannelevent nonPortable} { file delete $path(test1) set f [open $path(test1) w] close $f set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list delhandler $f]] proc delhandler {f} { variable z set z called testchannelevent $f delete 0 } set z not_called update close $f set z } called test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent nonPortable} { file delete $path(test1) set f [open $path(test1) w] close $f set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list delhandler $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] proc delhandler {f i} { variable z lappend z "called delhandler $f $i" testchannelevent $f delete 0 } set z "" update close $f string compare [string tolower $z] \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } 0 test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent nonPortable} { file delete $path(test1) set f [open $path(test1) w] close $f set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] set z "" |
︙ | ︙ | |||
6774 6775 6776 6777 6778 6779 6780 | set z "" update close $f string compare [string tolower $z] \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] } 0 | | | 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 | set z "" update close $f string compare [string tolower $z] \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] } 0 test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} { file delete $path(test1) set f [open $path(test1) w] close $f set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list delrecursive $f]] proc delrecursive {f} { variable z |
︙ | ︙ | |||
6796 6797 6798 6799 6800 6801 6802 | update } } variable u toplevel variable z "" update close $f | | | < | | 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 | update } } variable u toplevel variable z "" update close $f set z } {{delrecursive calling recursive} {delrecursive deleting recursive}} test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} { file delete $path(test1) set f [open $path(test1) w] close $f set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f]] testchannelevent $f add readable [namespace code [list del $f]] proc notcalled {f} { |
︙ | ︙ | |||
6829 6830 6831 6832 6833 6834 6835 | lappend z "del after update" } } set z "" set u toplevel update close $f | | | | < | | 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 | lappend z "del after update" } } set z "" set u toplevel update close $f set z } [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} { file delete $path(test1) set f [open $path(test1) w] close $f set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list second $f]] testchannelevent $f add readable [namespace code [list first $f]] proc first {f} { |
︙ | ︙ | |||
6871 6872 6873 6874 6875 6876 6877 | testchannelevent $f removeall } } set z "" set u toplevel update close $f | | | | | < | 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 | testchannelevent $f removeall } } set z "" set u toplevel update close $f set z } [list {first called} {first called not toplevel} \ {second called, first time} {second called, second time} \ {first after update}] test io-51.1 {Test old socket deletion on Macintosh} {socket} { set x 0 set result "" proc accept {s a p} { variable x variable wait |
︙ | ︙ |
Changes to jni/tcl/tests/package.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { package require tcltest 2.3.3 namespace import -force ::tcltest::* } | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { package require tcltest 2.3.3 namespace import -force ::tcltest::* } # Do all this in a child interp to avoid garbaging the package list set i [interp create] tcltest::loadIntoChildInterpreter $i {*}$argv interp eval $i { namespace import -force ::tcltest::* package forget {*}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path set auto_path "" |
︙ | ︙ | |||
858 859 860 861 862 863 864 | test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 x.y-3.2 } -returnCodes error -result {expected version number but got "x.y"} # No tests for FindPackage; can't think up anything detectable errors. test package-5.1 {TclFreePackageInfo procedure} { | | | | | 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 | test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 x.y-3.2 } -returnCodes error -result {expected version number but got "x.y"} # No tests for FindPackage; can't think up anything detectable errors. test package-5.1 {TclFreePackageInfo procedure} { interp create child child eval { package ifneeded t 2.3 x package ifneeded t 2.4 y package ifneeded x 3.1 z package provide q 4.3 package unknown "will this get freed?" } interp delete child } {} test package-5.2 {TclFreePackageInfo procedure} -body { interp create foo foo eval { package ifneeded t 2.3 x package ifneeded t 2.4 y package ifneeded x 3.1 z |
︙ | ︙ |
Changes to jni/tcl/tests/socket.test.
︙ | ︙ | |||
900 901 902 903 904 905 906 | test socket_$af-5.1 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 0x1} msg]} { close $msg return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} | | | | 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 | test socket_$af-5.1 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 0x1} msg]} { close $msg return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} } -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner} test socket_$af-5.2 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 0x10000} msg]} { close $msg return {port resolution problem, should be disallowed} } return {couldn't open socket: port number too high} } -constraints [list socket supported_$af] -result {couldn't open socket: port number too high} test socket_$af-5.3 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 21} msg]} { close $msg return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} } -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner} test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup { proc myHandler {msg options} { variable x $msg } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] |
︙ | ︙ |
Changes to jni/tcl/unix/tclUnixThrd.c.
︙ | ︙ | |||
18 19 20 21 22 23 24 | typedef struct ThreadSpecificData { char nabuf[16]; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* | | | | | | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | typedef struct ThreadSpecificData { char nabuf[16]; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * globalLock is used to serialize creation of mutexes, condition variables, * and thread local storage. This is the only place that can count on the * ability to statically initialize the mutex. */ static pthread_mutex_t globalLock = PTHREAD_MUTEX_INITIALIZER; /* * initLock is used to serialize initialization and finalization of Tcl. It * cannot use any dynamically allocated storage. */ static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER; /* * allocLock is used by Tcl's version of malloc for synchronization. For * obvious reasons, cannot use any dynamically allocated storage. */ static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER; static pthread_mutex_t *allocLockPtr = &allocLock; /* * These are for the critical sections inside this file. */ #define GLOBAL_LOCK pthread_mutex_lock(&globalLock) #define GLOBAL_UNLOCK pthread_mutex_unlock(&globalLock) #endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- * * TclpThreadCreate -- |
︙ | ︙ | |||
270 271 272 273 274 275 276 | void TclFinalizeLock(void) { #ifdef TCL_THREADS /* * You do not need to destroy mutexes that were created with the * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 | void TclFinalizeLock(void) { #ifdef TCL_THREADS /* * You do not need to destroy mutexes that were created with the * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any * destruction: globalLock, allocLock, and initLock. */ pthread_mutex_unlock(&initLock); #endif } /* |
︙ | ︙ | |||
305 306 307 308 309 310 311 | pthread_mutex_unlock(&initLock); #endif } /* *---------------------------------------------------------------------- * | | | | | | | | | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 | pthread_mutex_unlock(&initLock); #endif } /* *---------------------------------------------------------------------- * * TclpGlobalLock * * This procedure is used to grab a lock that serializes creation and * finalization of serialization objects. This interface is only needed * in finalization; it is hidden during creation of the objects. * * This lock must be different than the initLock because the initLock is * held during creation of synchronization objects. * * Results: * None. * * Side effects: * Acquire the global mutex. * *---------------------------------------------------------------------- */ void TclpGlobalLock(void) { #ifdef TCL_THREADS pthread_mutex_lock(&globalLock); #endif } /* *---------------------------------------------------------------------- * * TclpGlobalUnlock * * This procedure is used to release a lock that serializes creation and * finalization of synchronization objects. * * Results: * None. * * Side effects: * Release the global mutex. * *---------------------------------------------------------------------- */ void TclpGlobalUnlock(void) { #ifdef TCL_THREADS pthread_mutex_unlock(&globalLock); #endif } /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * * This procedure returns a pointer to a statically initialized mutex for * use by the memory allocator. The allocator must use this lock, because * all other locks are allocated... * * Results: * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and * Tcl_MutexUnlock. * * Side effects: |
︙ | ︙ | |||
417 418 419 420 421 422 423 | void Tcl_MutexLock( Tcl_Mutex *mutexPtr) /* Really (pthread_mutex_t **) */ { pthread_mutex_t *pmutexPtr; if (*mutexPtr == NULL) { | | | | | 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 | void Tcl_MutexLock( Tcl_Mutex *mutexPtr) /* Really (pthread_mutex_t **) */ { pthread_mutex_t *pmutexPtr; if (*mutexPtr == NULL) { GLOBAL_LOCK; if (*mutexPtr == NULL) { /* * Double inside global lock check to avoid a race condition. */ pmutexPtr = ckalloc(sizeof(pthread_mutex_t)); pthread_mutex_init(pmutexPtr, NULL); *mutexPtr = (Tcl_Mutex)pmutexPtr; TclRememberMutex(mutexPtr); } GLOBAL_UNLOCK; } pmutexPtr = *((pthread_mutex_t **)mutexPtr); pthread_mutex_lock(pmutexPtr); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
468 469 470 471 472 473 474 | *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * * This procedure is invoked to clean up one mutex. This is only safe to * call at the end of time. * | | | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 | *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * * This procedure is invoked to clean up one mutex. This is only safe to * call at the end of time. * * This assumes the Global Lock is held. * * Results: * None. * * Side effects: * The mutex list is deallocated. * |
︙ | ︙ | |||
528 529 530 531 532 533 534 | pthread_mutex_t *pmutexPtr; struct timespec ptime; #if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK) int *monoFlagPtr; #endif if (*condPtr == NULL) { | | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 | pthread_mutex_t *pmutexPtr; struct timespec ptime; #if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK) int *monoFlagPtr; #endif if (*condPtr == NULL) { GLOBAL_LOCK; /* * Double check inside mutex to avoid race, then initialize condition * variable if necessary. */ if (*condPtr == NULL) { |
︙ | ︙ | |||
559 560 561 562 563 564 565 | #else pcondPtr = ckalloc(sizeof(pthread_cond_t)); pthread_cond_init(pcondPtr, NULL); #endif *condPtr = (Tcl_Condition) pcondPtr; TclRememberCondition(condPtr); } | | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 | #else pcondPtr = ckalloc(sizeof(pthread_cond_t)); pthread_cond_init(pcondPtr, NULL); #endif *condPtr = (Tcl_Condition) pcondPtr; TclRememberCondition(condPtr); } GLOBAL_UNLOCK; } pmutexPtr = *((pthread_mutex_t **)mutexPtr); pcondPtr = *((pthread_cond_t **)condPtr); if (timePtr == NULL) { pthread_cond_wait(pcondPtr, pmutexPtr); } else { #if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK) |
︙ | ︙ | |||
630 631 632 633 634 635 636 | *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * | | | 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 | *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * * This assumes the Global Lock is held. * * Results: * None. * * Side effects: * The condition variable is deallocated. * |
︙ | ︙ | |||
818 819 820 821 822 823 824 | Tcl_Panic("unable to delete key!"); } TclpSysFree(keyPtr); } void | | | | | 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 843 844 | Tcl_Panic("unable to delete key!"); } TclpSysFree(keyPtr); } void TclpThreadSetGlobalTSD( void *tsdKeyPtr, void *ptr) { pthread_key_t *ptkeyPtr = tsdKeyPtr; if (pthread_setspecific(*ptkeyPtr, ptr)) { Tcl_Panic("unable to set global TSD value"); } } void * TclpThreadGetGlobalTSD( void *tsdKeyPtr) { pthread_key_t *ptkeyPtr = tsdKeyPtr; return pthread_getspecific(*ptkeyPtr); } |
︙ | ︙ |
Changes to jni/tcl/win/tclWinThrd.c.
︙ | ︙ | |||
20 21 22 23 24 25 26 | # define _MCW_EM 0x0008001F /* Error masks */ # define _MCW_RC 0x00000300 /* Rounding */ # define _MCW_PC 0x00030000 /* Precision */ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask); #endif /* | | | | | | | | 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 | # define _MCW_EM 0x0008001F /* Error masks */ # define _MCW_RC 0x00000300 /* Rounding */ # define _MCW_PC 0x00030000 /* Precision */ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask); #endif /* * This is the global lock used to serialize access to other serialization * data structures. */ static CRITICAL_SECTION globalLock; static int init = 0; #define GLOBAL_LOCK TclpGlobalLock() #define GLOBAL_UNLOCK TclpGlobalUnlock() /* * This is the global lock used to serialize initialization and finalization * of Tcl as a whole. */ static CRITICAL_SECTION initLock; /* * allocLock is used by Tcl's version of malloc for synchronization. For * obvious reasons, cannot use any dynamically allocated storage. */ #ifdef TCL_THREADS static struct Tcl_Mutex_ { CRITICAL_SECTION crit; } allocLock; |
︙ | ︙ | |||
364 365 366 367 368 369 370 | * interpreter has been created, it is safe to create more threads * that create interpreters in parallel. */ init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); | | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 | * interpreter has been created, it is safe to create more threads * that create interpreters in parallel. */ init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); InitializeCriticalSection(&globalLock); } EnterCriticalSection(&initLock); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
395 396 397 398 399 400 401 | { LeaveCriticalSection(&initLock); } /* *---------------------------------------------------------------------- * | | | | | | | | | | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 | { LeaveCriticalSection(&initLock); } /* *---------------------------------------------------------------------- * * TclpGlobalLock * * This procedure is used to grab a lock that serializes creation of * mutexes, condition variables, and thread local storage keys. * * This lock must be different than the initLock because the initLock is * held during creation of synchronization objects. * * Results: * None. * * Side effects: * Acquire the global mutex. * *---------------------------------------------------------------------- */ void TclpGlobalLock(void) { if (!init) { /* * There is a fundamental race here that is solved by creating the * first Tcl interpreter in a single threaded environment. Once the * interpreter has been created, it is safe to create more threads * that create interpreters in parallel. */ init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); InitializeCriticalSection(&globalLock); } EnterCriticalSection(&globalLock); } /* *---------------------------------------------------------------------- * * TclpGlobalUnlock * * This procedure is used to release a lock that serializes creation and * deletion of synchronization objects. * * Results: * None. * * Side effects: * Release the global mutex. * *---------------------------------------------------------------------- */ void TclpGlobalUnlock(void) { LeaveCriticalSection(&globalLock); } /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * * This procedure returns a pointer to a statically initialized mutex for * use by the memory allocator. The allocator must use this lock, because * all other locks are allocated... * * Results: * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and * Tcl_MutexUnlock. * * Side effects: |
︙ | ︙ | |||
508 509 510 511 512 513 514 | * *---------------------------------------------------------------------- */ void TclFinalizeLock(void) { | | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 | * *---------------------------------------------------------------------- */ void TclFinalizeLock(void) { GLOBAL_LOCK; DeleteCriticalSection(&joinLock); /* * Destroy the critical section that we are holding! */ DeleteCriticalSection(&globalLock); init = 0; #ifdef TCL_THREADS if (allocOnce) { DeleteCriticalSection(&allocLock.crit); allocOnce = 0; } |
︙ | ︙ | |||
563 564 565 566 567 568 569 | void Tcl_MutexLock( Tcl_Mutex *mutexPtr) /* The lock */ { CRITICAL_SECTION *csPtr; if (*mutexPtr == NULL) { | | | | | 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 | void Tcl_MutexLock( Tcl_Mutex *mutexPtr) /* The lock */ { CRITICAL_SECTION *csPtr; if (*mutexPtr == NULL) { GLOBAL_LOCK; /* * Double inside global lock check to avoid a race. */ if (*mutexPtr == NULL) { csPtr = ckalloc(sizeof(CRITICAL_SECTION)); InitializeCriticalSection(csPtr); *mutexPtr = (Tcl_Mutex)csPtr; TclRememberMutex(mutexPtr); } GLOBAL_UNLOCK; } csPtr = *((CRITICAL_SECTION **)mutexPtr); EnterCriticalSection(csPtr); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
677 678 679 680 681 682 683 | /* * Self initialize the two parts of the condition. The per-condition and * per-thread parts need to be handled independently. */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { | | | | | | | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 | /* * Self initialize the two parts of the condition. The per-condition and * per-thread parts need to be handled independently. */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { GLOBAL_LOCK; /* * Create the per-thread event and queue pointers. */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */, FALSE /* non signaled */, NULL); tsdPtr->nextPtr = NULL; tsdPtr->prevPtr = NULL; tsdPtr->flags = WIN_THREAD_RUNNING; doExit = 1; } GLOBAL_UNLOCK; if (doExit) { /* * Create a per-thread exit handler to clean up the condEvent. We * must be careful to do this outside the Global Lock because * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData, * and initializing that may drop back into the Global Lock. */ Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr); } } if (*condPtr == NULL) { GLOBAL_LOCK; /* * Initialize the per-condition queue pointers and Mutex. */ if (*condPtr == NULL) { winCondPtr = ckalloc(sizeof(WinCondition)); InitializeCriticalSection(&winCondPtr->condLock); winCondPtr->firstPtr = NULL; winCondPtr->lastPtr = NULL; *condPtr = (Tcl_Condition) winCondPtr; TclRememberCondition(condPtr); } GLOBAL_UNLOCK; } csPtr = *((CRITICAL_SECTION **)mutexPtr); winCondPtr = *((WinCondition **)condPtr); if (timePtr == NULL) { wtime = INFINITE; } else { wtime = timePtr->sec * 1000 + timePtr->usec / 1000; |
︙ | ︙ | |||
898 899 900 901 902 903 904 | *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * | | | 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 | *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * * This assumes the Global Lock is held. * * Results: * None. * * Side effects: * The condition variable is deallocated. * |
︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 | Tcl_Panic("unable to delete key"); } TclpSysFree(keyPtr); } void | | | | | 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 | Tcl_Panic("unable to delete key"); } TclpSysFree(keyPtr); } void TclpThreadSetGlobalTSD( void *tsdKeyPtr, void *ptr) { DWORD *key = tsdKeyPtr; if (!TlsSetValue(*key, ptr)) { Tcl_Panic("unable to set global TSD value"); } } void * TclpThreadGetGlobalTSD( void *tsdKeyPtr) { DWORD *key = tsdKeyPtr; return TlsGetValue(*key); } |
︙ | ︙ |