Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Merge trunk |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | gahr-tip-447 |
Files: | files | file ages | folders |
SHA1: |
5ae33611508108f3b3f94cdc53cbc5ef |
User & Date: | gahr 2016-05-23 11:40:10.752 |
Context
2016-06-01
| ||
09:55 | Merge TIP #447: Execution Time Verbosity Levels in tcltest::configure check-in: d0a72c427c user: gahr tags: trunk | |
2016-05-23
| ||
11:40 | Merge trunk Closed-Leaf check-in: 5ae3361150 user: gahr tags: gahr-tip-447 | |
2016-05-21
| ||
09:30 | Fix for [f97d4ee020]; use a two-stage approach to avoid quadratic behavior. check-in: 1b2b0fb52b user: dkf tags: trunk | |
2016-05-04
| ||
12:23 | Add a note in tcltest manual page to betray false expectations on msec and usec. check-in: 2b96efaf27 user: gahr tags: gahr-tip-447 | |
Changes
Changes to generic/tclAssembly.c.
︙ | ︙ | |||
3978 3979 3980 3981 3982 3983 3984 | /* * Unstack any catches that are deeper than the nesting level of the basic * block being entered. */ while (catchDepth > bbPtr->catchDepth) { --catchDepth; | > | | | | > | 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 | /* * Unstack any catches that are deeper than the nesting level of the basic * block being entered. */ while (catchDepth > bbPtr->catchDepth) { --catchDepth; if (catches[catchDepth] != NULL) { range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; range->numCodeBytes = bbPtr->startOffset - range->codeOffset; catches[catchDepth] = NULL; catchIndices[catchDepth] = -1; } } /* * Unstack any catches that don't match the basic block being entered, * either because they are no longer part of the context, or because the * context has changed from INCATCH to CAUGHT. */ |
︙ | ︙ |
Changes to generic/tclCompile.c.
︙ | ︙ | |||
989 990 991 992 993 994 995 | * Also releases its literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ void TclPreserveByteCode( | | | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 | * Also releases its literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ void TclPreserveByteCode( register ByteCode *codePtr) { codePtr->refCount++; } void TclReleaseByteCode( register ByteCode *codePtr) |
︙ | ︙ |
Changes to generic/tclEncoding.c.
︙ | ︙ | |||
351 352 353 354 355 356 357 358 359 360 361 362 363 364 | static void DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); } /* *---------------------------------------------------------------------- * * Tcl_GetEncodingSearchPath -- * | > | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 | static void DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); dupPtr->typePtr = &encodingType; } /* *---------------------------------------------------------------------- * * Tcl_GetEncodingSearchPath -- * |
︙ | ︙ |
Changes to generic/tclNamesp.c.
︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 | TclTeardownNamespace( register Namespace *nsPtr) /* Points to the namespace to be dismantled * and unlinked from its parent. */ { Interp *iPtr = (Interp *) nsPtr->interp; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; | < < > > > | | | < > > > > > | | | | > > > > | > > > > | 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 | TclTeardownNamespace( register Namespace *nsPtr) /* Points to the namespace to be dismantled * and unlinked from its parent. */ { Interp *iPtr = (Interp *) nsPtr->interp; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; int i; /* * Start by destroying the namespace's variable table, since variables * might trigger traces. Variable table should be cleared but not freed! * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards. */ TclDeleteNamespaceVars(nsPtr); TclInitVarHashTable(&nsPtr->varTable, nsPtr); /* * Delete all commands in this namespace. Be careful when traversing the * hash table: when each command is deleted, it removes itself from the * command table. Because of traces (and the desire to avoid the quadratic * problems of just using Tcl_FirstHashEntry over and over, [Bug * f97d4ee020]) we copy to a temporary array and then delete all those * commands. */ while (nsPtr->cmdTable.numEntries > 0) { int length = nsPtr->cmdTable.numEntries; Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Command *) * length); i = 0; for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { cmds[i] = Tcl_GetHashValue(entryPtr); cmds[i]->refCount++; i++; } for (i = 0 ; i < length ; i++) { Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, (Tcl_Command) cmds[i]); TclCleanupCommandMacro(cmds[i]); } TclStackFree((Tcl_Interp *) iPtr, cmds); } Tcl_DeleteHashTable(&nsPtr->cmdTable); Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); /* * Remove the namespace from its parent's child hashtable. */ |
︙ | ︙ | |||
1171 1172 1173 1174 1175 1176 1177 | } /* * Delete all the child namespaces. * * BE CAREFUL: When each child is deleted, it will divorce itself from its * parent. You can't traverse a hash table properly if its elements are | > | > > < > > > > > > > | | | | > > > > | > | > > > > > > > > | | | | > > > > | > > > | 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 | } /* * Delete all the child namespaces. * * BE CAREFUL: When each child is deleted, it will divorce itself from its * parent. You can't traverse a hash table properly if its elements are * being deleted. Because of traces (and the desire to avoid the * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug * f97d4ee020]) we copy to a temporary array and then delete all those * namespaces. * * Important: leave the hash table itself still live. */ #ifndef BREAK_NAMESPACE_COMPAT while (nsPtr->childTable.numEntries > 0) { int length = nsPtr->childTable.numEntries; Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Namespace *) * length); i = 0; for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { children[i] = Tcl_GetHashValue(entryPtr); children[i]->refCount++; i++; } for (i = 0 ; i < length ; i++) { Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); TclNsDecrRefCount(children[i]); } TclStackFree((Tcl_Interp *) iPtr, children); } #else if (nsPtr->childTablePtr != NULL) { while (nsPtr->childTablePtr->numEntries > 0) { int length = nsPtr->childTablePtr->numEntries; Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Namespace *) * length); i = 0; for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { children[i] = Tcl_GetHashValue(entryPtr); children[i]->refCount++; i++; } for (i = 0 ; i < length ; i++) { Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); TclNsDecrRefCount(children[i]); } TclStackFree((Tcl_Interp *) iPtr, children); } } #endif /* * Free the namespace's export pattern array. */ |
︙ | ︙ |
Changes to library/reg/pkgIndex.tcl.
1 2 3 | if {([info commands ::tcl::pkgconfig] eq "") || ([info sharedlibextension] ne ".dll")} return if {[::tcl::pkgconfig get debug]} { | | | | 1 2 3 4 5 6 7 8 9 | if {([info commands ::tcl::pkgconfig] eq "") || ([info sharedlibextension] ne ".dll")} return if {[::tcl::pkgconfig get debug]} { package ifneeded registry 1.3.2 \ [list load [file join $dir tclreg13g.dll] registry] } else { package ifneeded registry 1.3.2 \ [list load [file join $dir tclreg13.dll] registry] } |
Changes to tests/assemble.test.
︙ | ︙ | |||
3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 | catch { apply {{} { assemble {reverse polish notation} }} } } } 0 rename fillTables {} rename assemble {} ::tcltest::cleanupTests return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 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 | catch { apply {{} { assemble {reverse polish notation} }} } } } 0 test assemble-52.1 {Bug 3154ea2759} { apply {{} { # Needs six exception ranges to force the range allocations to use the # malloced store. ::tcl::unsupported::assemble { beginCatch @badLabel push error push testing invokeStk 2 pop push 0 jump @okLabel label @badLabel push 1; # should be pushReturnCode label @okLabel endCatch pop beginCatch @badLabel2 push error push testing invokeStk 2 pop push 0 jump @okLabel2 label @badLabel2 push 1; # should be pushReturnCode label @okLabel2 endCatch pop beginCatch @badLabel3 push error push testing invokeStk 2 pop push 0 jump @okLabel3 label @badLabel3 push 1; # should be pushReturnCode label @okLabel3 endCatch pop beginCatch @badLabel4 push error push testing invokeStk 2 pop push 0 jump @okLabel4 label @badLabel4 push 1; # should be pushReturnCode label @okLabel4 endCatch pop beginCatch @badLabel5 push error push testing invokeStk 2 pop push 0 jump @okLabel5 label @badLabel5 push 1; # should be pushReturnCode label @okLabel5 endCatch pop beginCatch @badLabel6 push error push testing invokeStk 2 pop push 0 jump @okLabel6 label @badLabel6 push 1; # should be pushReturnCode label @okLabel6 endCatch pop } }} } {}; # must not crash rename fillTables {} rename assemble {} ::tcltest::cleanupTests return |
︙ | ︙ |
Changes to tests/namespace.test.
︙ | ︙ | |||
2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 | rename getbytes {} unset i ns start end } -result 0 test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} { info class [format %s constructor] oo::object } "" # cleanup catch {rename cmd1 {}} catch {unset l} catch {unset msg} catch {unset trigger} namespace delete {*}[namespace children :: test_ns_*] | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 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 3001 | rename getbytes {} unset i ns start end } -result 0 test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} { info class [format %s constructor] oo::object } "" test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} { namespace eval ::testing { proc abc {} {} proc def {} {} trace add command abc delete "rename ::testing::def {}; #" trace add command def delete "rename ::testing::abc {}; #" } namespace delete ::testing } {} test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} { namespace eval ::testing { namespace eval abc {proc xyz {} {}} namespace eval def {proc xyz {} {}} trace add command abc::xyz delete "namespace delete ::testing::def {}; #" trace add command def::xyz delete "namespace delete ::testing::abc {}; #" } namespace delete ::testing } {} test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} { namespace eval ::testing { variable gone {} oo::class create CB { variable cmd constructor other {set cmd $other} destructor {rename $cmd {}; lappend ::testing::gone $cmd} } namespace eval abc { ::testing::CB create def ::testing::abc::ghi ::testing::CB create ghi ::testing::abc::def } namespace delete abc try { return [lsort $gone] } finally { namespace delete ::testing } } } {::testing::abc::def ::testing::abc::ghi} # cleanup catch {rename cmd1 {}} catch {unset l} catch {unset msg} catch {unset trigger} namespace delete {*}[namespace children :: test_ns_*] |
︙ | ︙ |
Changes to tests/registry.test.
︙ | ︙ | |||
15 16 17 18 19 20 21 | namespace import -force ::tcltest::* } testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands | | | | 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 | namespace import -force ::tcltest::* } testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands set ::regver [package require registry 1.3.2] }]} { testConstraint reg 1 } } # determine the current locale testConstraint english [expr { [llength [info commands testlocale]] && [string match "English*" [testlocale all ""]] }] test registry-1.0 {check if we are testing the right dll} {win reg} { set ::regver } {1.3.2} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} test registry-1.1a {argument parsing for registry command} {win reg} { list [catch {registry -32bit} msg] $msg } {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} test registry-1.1b {argument parsing for registry command} {win reg} { |
︙ | ︙ |
Changes to win/Makefile.in.
︙ | ︙ | |||
709 710 711 712 713 714 715 | test: test-tcl test-packages test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ | | | | 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 | test: test-tcl test-packages test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.2 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) # Useful target to launch a built tclsh with the proper path,... runtest: binaries $(TCLSH) $(TEST_DLL_FILE) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.2 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` shell: binaries @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) $(SCRIPT) |
︙ | ︙ |
Changes to win/makefile.vc.
︙ | ︙ | |||
585 586 587 588 589 590 591 | test: test-core test-pkgs test-core: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] | | | | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 | test: test-core test-pkgs test-core: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.2 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.2 "$(TCLREGLIB:\=/)" registry] << type tests.log | more !endif runtest: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) $(SCRIPT) |
︙ | ︙ |
Changes to win/tclWinReg.c.
︙ | ︙ | |||
159 160 161 162 163 164 165 | if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); return Tcl_PkgProvide(interp, "registry", "1.3.2"); } /* *---------------------------------------------------------------------- * * Registry_Unload -- * |
︙ | ︙ | |||
799 800 801 802 803 804 805 | /* * Multistrings are stored as an array of null-terminated strings, * terminated by two null characters. Also do a bounds check in case * we get bogus data. */ | | | | | | | 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 | /* * Multistrings are stored as an array of null-terminated strings, * terminated by two null characters. Also do a bounds check in case * we get bogus data. */ while ((p < end) && *((WCHAR *) p) != 0) { WCHAR *wp; Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); wp = (WCHAR *) p; while (*wp++ != 0) {/* empty body */} p = (char *) wp; Tcl_DStringFree(&buf); } Tcl_SetObjResult(interp, resultPtr); } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); Tcl_DStringResult(interp, &buf); } else { |
︙ | ︙ | |||
1328 1329 1330 1331 1332 1333 1334 | Tcl_DString buf; const char *data = Tcl_GetString(dataObj); length = dataObj->length; data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* | | | 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 | Tcl_DString buf; const char *data = Tcl_GetString(dataObj); length = dataObj->length; data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* * Include the null in the length, padding if needed for WCHAR. */ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); length = Tcl_DStringLength(&buf) + 1; result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) data, (DWORD) length); |
︙ | ︙ | |||
1389 1390 1391 1392 1393 1394 1395 | int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { LRESULT result; DWORD_PTR sendResult; int timeout = 3000; size_t len; | < > > | > > | | | > | | | 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 | int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { LRESULT result; DWORD_PTR sendResult; int timeout = 3000; size_t len; const char *str; Tcl_Obj *objPtr; WCHAR *wstr; Tcl_DString ds; if (objc == 3) { str = Tcl_GetString(objv[1]); len = objv[1]->length; if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) { return TCL_BREAK; } if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) { return TCL_ERROR; } } str = Tcl_GetString(objv[0]); len = objv[0]->length; wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } /* * Use the ignore the result. */ result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, (WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); Tcl_DStringFree(&ds); objPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result)); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult)); Tcl_SetObjResult(interp, objPtr); return TCL_OK; } /* *---------------------------------------------------------------------- |
︙ | ︙ |