Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,13 +1,69 @@ +2012-05-21 Don Porter + + * generic/tclFileName.c: When using Tcl_SetObjLength() calls to grow + * generic/tclPathObj.c: and shrink the objPtr->bytes buffer, care must be + taken that the value cannot possibly become pure Unicode. Calling + Tcl_AppendToObj() has the possibility of making such a conversion. Bug + found while valgrinding the trunk. + +2012-05-21 Jan Nijtmans + + * win/tclWinDde.c: TIP #106: Add Encoding Abilities to the [dde] + * library/dde/pkgIndex.tcl: Command. Dde version is now 1.4.0. + * tests/winDde.test: + * doc/dde.n: + +2012-05-20 Donal K. Fellows + + * generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut + the amount of hackiness in class constructors, and refactor some of + the error message handling from [oo::define] to be saner in the face + of odd happenings. + +2012-05-17 Donal K. Fellows + + * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): [Bug 3106532]: Corrected + resulting indexes from -indexvar option to be usable with [string + range]; this was always the intention (and is consistent with [regexp + -indices] too). + ***POTENTIAL INCOMPATIBILITY*** + Uses of [switch -regexp -indexvar] that previously compensated for the + wrong offsets (by subtracting 1 from the end indices) now do not need + to do so as the value is correct. + + * library/safe.tcl (safe::InterpInit): Ensure that the module path is + constructed in the correct order. + (safe::AliasGlob): [Bug 2964715]: More extensive handling of what + globbing is required to support package loading. + + * doc/expr.n: [Bug 3525462]: Corrected statement about what happens + when comparing "0y" and "0x12"; the previously documented behavior was + actually a subtle bug (now long-corrected). + +2012-05-16 Donal K. Fellows + + * generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3445787]: Improve + the compatibility of safe interpreters' version of 'file' with that of + unsafe interpreters. + * library/safe.tcl (::safe::InterpInit): Teach the safe-interp scripts + about how to expose 'file' properly. + +2012-05-13 Jan Nijtmans + + * win/tclWinDde.c: Protect against receiving strings without ending + \0, as external applications (or Tcl with TIP #106) could generate + that. + 2012-05-10 Jan Nijtmans - * win/tclWinDde.c: [Bug 473946]: special characters not correctly sent - * library/dde/pkgIndex.tcl Increase version to 1.3.3 + * win/tclWinDde.c: [Bug 473946]: Special characters not correctly sent + * library/dde/pkgIndex.tcl: Increase version to 1.3.3 2012-05-10 Alexandre Ferrieux - * {win,unix}/configure{,.in} [Bug 2812981]: Clean up bundled + * {win,unix}/configure{,.in}: [Bug 2812981]: Clean up bundled packages' build directory from within Tcl's ./configure, to avoid stale configuration. 2012-05-09 Andreas Kupries @@ -14,11 +70,11 @@ * generic/tclIORChan.c [Bug 3522560]: Fixed the crash, enabled the test case. Modified [chan postevent] to properly inject the event(s) into the owner thread's event queue for execution in the correct context. Renamed the ForwardOpTo...Thread() function to match with our terminology. - + * tests/ioCmd.test [Bug 3522560]: Added a test which crashes the core if it were not disabled as knownBug. For a reflected channel transfered to a different thread the [chan postevent] run in the handler thread tries to execute the owner threads's fileevent scripts by itself, wrongly reaching across thread boundaries. @@ -28,33 +84,34 @@ * generic/tclIO.c: Properly close nonblocking channels even when not flushing them. 2012-05-03 Jan Nijtmans - * compat/zlib/*: Upgrade to zlib 1.2.7 (pre-built dll is still 1.2.5, + * compat/zlib/*: Upgrade to zlib 1.2.7 (pre-built dll is still 1.2.5, will be upgraded as soon as the official build is available) 2012-05-03 Don Porter - * tests/socket.test: [Bug 3428754] Test socket-14.2 tolerate + * tests/socket.test: [Bug 3428754]: Test socket-14.2 tolerate [socket -async] connection that connects synchronously. - * unix/tclUnixSock.c: [Bug 3428753] Fix [socket -async] connections + * unix/tclUnixSock.c: [Bug 3428753]: Fix [socket -async] connections that manage to connect synchronously. 2012-05-02 Jan Nijtmans - * generic/configure.in: Better detection and implementation for cpuid - * generic/configure: instruction on Intel-derived processors, both - * generic/tclUnixCompat.c: 32-bit and 64-bit. - * generic/tclTest.c: Move cpuid testcase from win-specific to generic - * win/tclWinTest.c: tests, as it should work on all Intel-related - * tests/platform.test: platforms now + * generic/configure.in: Better detection and implementation for + * generic/configure: cpuid instruction on Intel-derived + * generic/tclUnixCompat.c: processors, both 32-bit and 64-bit. + * generic/tclTest.c: Move cpuid testcase from win-specific to + * win/tclWinTest.c: generic tests, as it should work on all + * tests/platform.test: Intel-related platforms now. 2012-04-30 Alexandre Ferrieux - * tests/ioCmd.test: Tame deadlocks in broken refchan tests [Bug 3522560] + * tests/ioCmd.test: [Bug 3522560]: Tame deadlocks in broken refchan + tests. 2012-04-28 Alexandre Ferrieux IMPLEMENTATION OF TIP#398 @@ -93,14 +150,15 @@ with this: obj=TclDStringToObj(&ds); 2012-04-24 Jan Nijtmans - * generic/tclInt.decls: [Bug 3508771] load tclreg.dll in cygwin tclsh - * generic/tclIntPlatDecls.h: Implement TclWinGetSockOpt, TclWinGetServByName - * generic/tclStubInit.c: and TclWinCPUID for Cygwin - * generic/tclUnixCompat.c: + * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin + tclsh + * generic/tclIntPlatDecls.h: Implement TclWinGetSockOpt, + * generic/tclStubInit.c: TclWinGetServByName and TclWinCPUID for + * generic/tclUnixCompat.c: Cygwin. * unix/configure.in: * unix/configure: * unix/tclUnixCompat.c: 2012-04-18 Kevin B. Kenny @@ -506,14 +564,14 @@ 2012-01-21 Jan Nijtmans * generic/tcl.h: [Bug 3474726]: Eliminate detection of struct * generic/tclWinPort.h: _stat32i64, just use _stati64 in combination - * generic/tclFCmd.c: with _USE_32BIT_TIME_T, which is the same then. - * generic/tclTest.c: Only keep _stat32i64 usage for cygwin, so it - * win/configure.in: will not conflict with cygwin's own struct stat. - * win/configure: + * generic/tclFCmd.c: with _USE_32BIT_TIME_T, which is the same + * generic/tclTest.c: then. Only keep _stat32i64 usage for cygwin, + * win/configure.in: so it will not conflict with cygwin's own + * win/configure: struct stat. 2012-01-21 Don Porter * generic/tclCmdMZ.c: [Bug 3475667]: Prevent buffer read overflow. Thanks to "sebres" for the report and fix. @@ -532,13 +590,13 @@ * doc/tclvars.n: [Bug 3466506]: Document more environment variables. 2012-01-09 Jan Nijtmans - * generic/tclUtf.c: [Bug 3464428]: string is graph \u0120 is wrong - * generic/regc_locale.c: Add table for Unicode [:cntrl:] class - * tools/uniClass.tcl: Generate Unicode [:cntrl:] class table + * generic/tclUtf.c: [Bug 3464428]: [string is graph \u0120] was + * generic/regc_locale.c: wrong. Add table for Unicode [:cntrl:] class. + * tools/uniClass.tcl: Generate Unicode [:cntrl:] class table. * tests/utf.test: 2012-01-08 Kevin B. Kenny * library/clock.tcl (ReadZoneinfoFile): [Bug 3470928]: Corrected a bug @@ -558,11 +616,11 @@ * library/tzdata/Europe/Zaporozhye * library/tzdata/Pacific/Fiji 2011-12-23 Jan Nijtmans - * generic/tclUtf.c: [Bug 3464428]: string is graph \u0120 is wrong. + * generic/tclUtf.c: [Bug 3464428]: [string is graph \u0120] is wrong. * generic/tclUniData.c: * generic/regc_locale.c: * tests/utf.test: * tools/uniParse.tcl: Clean up some unused stuff, and be more robust against changes in UnicodeData.txt syntax @@ -1346,11 +1404,12 @@ * generic/tclLink.c: [Bug 3317466]: Prevent multiple links to a single Tcl variable when calling Tcl_LinkVar(). 2011-06-13 Don Porter - * generic/tclStrToD.c: [Bug 3315098]: Mem leak fix from Gustaf Neumann. + * generic/tclStrToD.c: [Bug 3315098]: Mem leak fix from Gustaf + Neumann. 2011-06-08 Andreas Kupries * generic/tclExecute.c: Reverted the fix for [Bug 3274728] committed on 2011-04-06 and replaced with one which is 64bit-safe. The existing @@ -2082,13 +2141,13 @@ 2011-01-25 Jan Nijtmans * generic/tclPreserve.c: Don't miss 64-bit address bits in panic message. - * win/tclWinChan.c: Fix various gcc-4.5.2 64-bit warning messages - * win/tclWinConsole.c e.g. by using full 64-bits for socket fd's - * win/tclWinDde.c + * win/tclWinChan.c: Fix various gcc-4.5.2 64-bit warning + * win/tclWinConsole.c: messages, e.g. by using full 64-bits for + * win/tclWinDde.c: socket fd's * win/tclWinPipe.c * win/tclWinReg.c * win/tclWinSerial.c * win/tclWinSock.c * win/tclWinThrd.c @@ -2493,12 +2552,12 @@ * win/tclAppInit.c:Bring compilation under mingw-w64 a bit closer * win/cat.c: to reality. See for what's missing: * win/tcl.m4: * win/configure: (re-generated) - * win/tclWinPort.h:[Bug #3110161]: Extensions using TCHAR don't compile - on VS2005 SP1 + * win/tclWinPort.h: [Bug #3110161]: Extensions using TCHAR don't + compile on VS2005 SP1 2010-11-15 Andreas Kupries * doc/interp.n: [Bug 3081184]: TIP #378. * doc/tclvars.n: Performance fix for TIP #280. @@ -2645,13 +2704,13 @@ 2010-10-24 Kevin B. Kenny [dogeen-assembler-branch] * generic/tclAssembly.c: - * tests/assembly.test (assemble-17.15): Reworked branch handling so that - forward branches can use jump1 (jumpTrue1, jumpFalse1). Added test - cases that the forward branches will expand to jump4, jumpTrue4, + * tests/assembly.test (assemble-17.15): Reworked branch handling so + that forward branches can use jump1 (jumpTrue1, jumpFalse1). Added + test cases that the forward branches will expand to jump4, jumpTrue4, jumpFalse4 when needed. 2010-10-23 Kevin B. Kenny [dogeen-assembler-branch] @@ -2752,11 +2811,12 @@ * win/tclWinDde.c: [FRQ 2965056]: Windows build with -DUNICODE * win/tclWinReg.c: * win/tclWinTest.c: More cleanups * win/tclWinFile.c: Add netapi32 to the link line, so we no longer - * win/tcl.m4: have to use LoadLibrary to access those functions. + * win/tcl.m4: have to use LoadLibrary to access those + functions. * win/makefile.vc: * win/configure: (Re-generate with autoconf-2.59) * win/rules.vc Update for VS10 2010-10-09 Miguel Sofer @@ -3473,12 +3533,12 @@ * generic/tclIntDecls.h: make genstubs * generic/tclStubInit.c: 2010-07-02 Jan Nijtmans - * generic/tclInt.decls: [Bug 803489]: Tcl_FindNamespace problem in the - * generic/tclIntDecls.h: Stubs table + * generic/tclInt.decls: [Bug 803489]: Tcl_FindNamespace problem in + * generic/tclIntDecls.h: the Stubs table * generic/tclStubInit.c: 2010-07-02 Donal K. Fellows * generic/tclExecute.c (IllegalExprOperandType): [Bug 3024379]: Made @@ -5675,14 +5735,15 @@ to: typedef unsigned int mp_digit; For 32-bit builds where "long" and "int" are two names for the same thing, this is no change at all. For 64-bit builds, though, this causes the dp[] array of an mp_int to be made up of 32-bit elements - instead of 64-bit elements. This is a huge improvement because details - elsewhere in the mp_int implementation cause only 28 bits of each - element to be actually used storing number data. Without this change - bignums are over 50% wasted space on 64-bit systems. [Bug 2800740]. + instead of 64-bit elements. This is a huge improvement because + details elsewhere in the mp_int implementation cause only 28 bits of + each element to be actually used storing number data. Without this + change bignums are over 50% wasted space on 64-bit systems. [Bug + 2800740]. ***POTENTIAL INCOMPATIBILITY*** For 64-bit builds, callers of routines with (mp_digit) or (mp_digit *) arguments *will*, and callers of routines with (mp_int *) arguments *may* suffer both binary and stubs incompatibilities with Tcl releases @@ -5804,14 +5865,14 @@ and objThreadMap thread specific data members. 2009-10-18 Joe Mistachkin * tests/thread.test (thread-4.[345]): [Bug 1565466]: Correct tests to - save their error state before the final call to threadReap just in case - it triggers an "invalid thread id" error. This error can occur if one - or more of the target threads has exited prior to the attempt to send - it an asynchronous exit command. + save their error state before the final call to threadReap just in + case it triggers an "invalid thread id" error. This error can occur + if one or more of the target threads has exited prior to the attempt + to send it an asynchronous exit command. 2009-10-17 Donal K. Fellows * generic/tclVar.c (UnsetVarStruct, TclDeleteNamespaceVars) (TclDeleteCompiledLocalVars, DeleteArray): Index: doc/dde.n ================================================================== --- doc/dde.n +++ doc/dde.n @@ -81,13 +81,12 @@ script is run in the application. The \fB\-async\fR option requests asynchronous invocation. The command returns an error message if the script did not run, unless the \fB\-async\fR flag was used, in which case the command returns immediately with no error. .VS 8.6 -The \fB\-binary\fR option treats \fIdata\fR as binary data, otherwise an utf-8 -string is sent. Combining \fB-binary\fR with the result of -\fBencoding convertto\fR may be used to send data in arbitrary encodings. +The \fB\-binary\fR option treats \fIdata\fR as binary data, otherwise a +unicode string is sent. .VE 8.6 .TP \fBdde poke ?\fB\-binary\fR? \fIservice topic item data\fR . \fBdde poke\fR passes the \fIdata\fR to the server indicated by @@ -96,12 +95,12 @@ specific but can be a command to the server or the name of a file to work on. The \fIitem\fR is also application specific and is often not used, but it must always be non-null. The \fIdata\fR field is given to the remote application. .VS 8.6 -The \fB\-binary\fR option treats \fIdata\fR as binary data, otherwise an utf-8 -string is sent. +The \fB\-binary\fR option treats \fIdata\fR as binary data, otherwise a +unicode string is sent. .VE 8.6 .TP \fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR . \fBdde request\fR is typically used to get the value of something; the Index: doc/expr.n ================================================================== --- doc/expr.n +++ doc/expr.n @@ -324,10 +324,11 @@ .SS "STRING OPERATIONS" .PP String values may be used as operands of the comparison operators, although the expression evaluator tries to do comparisons as integer or floating-point when it can, +i.e., when all arguments to the operator allow numeric interpretations, except in the case of the \fBeq\fR and \fBne\fR operators. If one of the operands of a comparison is a string and the other has a numeric value, a canonical string representation of the numeric operand value is generated to compare with the string operand. Canonical string representation for integer values is a decimal string @@ -335,16 +336,15 @@ is that produced by the \fB%g\fR format specifier of Tcl's \fBformat\fR command. For example, the commands .PP .CS \fBexpr\fR {"0x03" > "2"} -\fBexpr\fR {"0y" < "0x12"} +\fBexpr\fR {"0y" > "0x12"} .CE .PP both return 1. The first comparison is done using integer -comparison, and the second is done using string comparison after -the second operand is converted to the string \fB18\fR. +comparison, and the second is done using string comparison. Because of Tcl's tendency to treat values as numbers whenever possible, it is not generally a good idea to use operators like \fB==\fR when you really want string comparison and the values of the operands could be arbitrary; it is better in these cases to use the \fBeq\fR or \fBne\fR operators, or the \fBstring\fR command instead. Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -2344,16 +2344,16 @@ } ################################ # Mac OS X specific functions -declare 0 {unix macosx} { +declare 0 macosx { int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath) } -declare 1 {unix macosx} { +declare 1 macosx { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath) } Index: generic/tclCmdAH.c ================================================================== --- generic/tclCmdAH.c +++ generic/tclCmdAH.c @@ -59,10 +59,11 @@ static Tcl_NRPostProc ForNextCallback; static Tcl_NRPostProc ForPostNextCallback; static Tcl_NRPostProc ForeachLoopStep; static Tcl_NRPostProc EvalCmdErrMsg; +static Tcl_ObjCmdProc BadFileSubcommand; static Tcl_ObjCmdProc FileAttrAccessTimeCmd; static Tcl_ObjCmdProc FileAttrIsDirectoryCmd; static Tcl_ObjCmdProc FileAttrIsExecutableCmd; static Tcl_ObjCmdProc FileAttrIsExistingCmd; static Tcl_ObjCmdProc FileAttrIsFileCmd; @@ -579,11 +580,11 @@ Tcl_FreeEncoding(encoding); break; } case ENC_DIRS: - return EncodingDirsObjCmd(dummy, interp, objc-1, objv+1); + return EncodingDirsObjCmd(dummy, interp, objc, objv); case ENC_NAMES: if (objc > 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -626,14 +627,16 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc > 2) { + if (objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?dirList?"); return TCL_ERROR; } + objc -= 1; + objv += 1; if (objc == 1) { Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath()); return TCL_OK; } if (Tcl_SetEncodingSearchPath(objv[1]) == TCL_ERROR) { @@ -1055,10 +1058,12 @@ || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) { Tcl_Panic("problem making 'file %s' safe: %s", unsafeInfo[i].cmdName, Tcl_GetString(Tcl_GetObjResult(interp))); } + Tcl_CreateObjCommand(interp, oldName, BadFileSubcommand, + (ClientData) unsafeInfo[i].cmdName, NULL); } } Tcl_DStringFree(&oldBuf); Tcl_DStringFree(&newBuf); @@ -1072,10 +1077,43 @@ Tcl_Panic("problem making 'file' safe: %s", Tcl_GetString(Tcl_GetObjResult(interp))); } return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * BadFileSubcommand -- + * + * Command used to act as a backstop implementation when subcommands of + * "file" are unsafe (the real implementations of the subcommands are + * hidden). The clientData is always the full official subcommand name. + * + * Results: + * A standard Tcl result (always a TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +BadFileSubcommand( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + const char *subcommandName = (const char *) clientData; + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "not allowed to invoke subcommand %s of file", subcommandName)); + Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- * * FileAttrAccessTimeCmd -- Index: generic/tclCmdMZ.c ================================================================== --- generic/tclCmdMZ.c +++ generic/tclCmdMZ.c @@ -3756,12 +3756,16 @@ for (j=0 ; j<=info.nsubs ; j++) { if (indexVarObj != NULL) { Tcl_Obj *rangeObjAry[2]; - rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); - rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end); + if (info.matches[j].end > 0) { + rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); + rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); + } else { + rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1); + } /* * Never fails; the object is always clean at this point. */ Index: generic/tclFileName.c ================================================================== --- generic/tclFileName.c +++ generic/tclFileName.c @@ -861,11 +861,11 @@ * Append a separator if needed. */ if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - length++; + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; /* * Append the element, eliminating duplicate and trailing slashes. @@ -897,11 +897,11 @@ */ if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - length++; + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; /* * Append the element, eliminating duplicate and trailing slashes. Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ generic/tclOO.c @@ -120,10 +120,20 @@ DCM("new", 1, TclOO_Class_New), DCM("createWithNamespace", 0, TclOO_Class_CreateNs), {NULL, 0, {0, NULL, NULL, NULL, NULL}} }; +/* + * And for the oo::class constructor... + */ + +static const Tcl_MethodType classConstructor = { + TCL_OO_METHOD_VERSION_CURRENT, + "oo::class constructor", + TclOO_Class_Constructor, NULL, NULL +}; + /* * Scripted parts of TclOO. First, the master script (cannot be outside this * file). */ @@ -132,22 +142,10 @@ "namespace eval ::oo { variable version " TCLOO_VERSION " };" "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; /* "tcl_findLibrary tcloo $oo::version $oo::version" */ /* " tcloo.tcl OO_LIBRARY oo::library;"; */ -/* - * The body of the constructor for oo::class. - */ - -static const char *classConstructorBody = -"set script [list ::oo::define [self] $definitionScript];" -"lassign [::oo::UpCatch $script] msg opts;" -"if {[dict get $opts -code] == 1} {" -" dict set opts -errorline 0xDeadBeef" -"};" -"return -options $opts $msg;"; - /* * The scripted part of the definitions of slots. */ static const char *slotScript = @@ -338,16 +336,16 @@ fPtr->tsdPtr = tsdPtr; TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown"); TclNewLiteralStringObj(fPtr->constructorName, ""); TclNewLiteralStringObj(fPtr->destructorName, ""); TclNewLiteralStringObj(fPtr->clonedName, ""); + TclNewLiteralStringObj(fPtr->defineName, "::oo::define"); Tcl_IncrRefCount(fPtr->unknownMethodNameObj); Tcl_IncrRefCount(fPtr->constructorName); Tcl_IncrRefCount(fPtr->destructorName); Tcl_IncrRefCount(fPtr->clonedName); - Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd, - TclOONRUpcatch, NULL, NULL); + Tcl_IncrRefCount(fPtr->defineName); Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition", TclOOUnknownDefinition, NULL, NULL); TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition"); Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr); Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr); @@ -416,32 +414,23 @@ TclNewLiteralStringObj(argsPtr, "originObject"); Tcl_IncrRefCount(argsPtr); bodyPtr = Tcl_NewStringObj(clonedBody, -1); TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, bodyPtr, NULL); - Tcl_DecrRefCount(argsPtr); + TclDecrRefCount(argsPtr); /* * Finish setting up the class of classes by marking the 'new' method as * private; classes, unlike general objects, must have explicit names. We * also need to create the constructor for classes. - * - * The 0xDeadBeef is a special signal to the errorInfo logger that is used - * by constructors that stops it from generating extra error information - * that is confusing. */ TclNewLiteralStringObj(namePtr, "new"); Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL); - - TclNewLiteralStringObj(argsPtr, "{definitionScript {}}"); - Tcl_IncrRefCount(argsPtr); - bodyPtr = Tcl_NewStringObj(classConstructorBody, -1); - fPtr->classCls->constructorPtr = TclOONewProcMethod(interp, - fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL); - Tcl_DecrRefCount(argsPtr); + fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, + (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); /* * Create non-object commands and plug ourselves into the Tcl [info] * ensemble. */ @@ -527,14 +516,15 @@ { Foundation *fPtr = GetFoundation(interp); DelRef(fPtr->objectCls->thisPtr); DelRef(fPtr->objectCls); - Tcl_DecrRefCount(fPtr->unknownMethodNameObj); - Tcl_DecrRefCount(fPtr->constructorName); - Tcl_DecrRefCount(fPtr->destructorName); - Tcl_DecrRefCount(fPtr->clonedName); + TclDecrRefCount(fPtr->unknownMethodNameObj); + TclDecrRefCount(fPtr->constructorName); + TclDecrRefCount(fPtr->destructorName); + TclDecrRefCount(fPtr->clonedName); + TclDecrRefCount(fPtr->defineName); ckfree(fPtr); } /* * ---------------------------------------------------------------------- @@ -787,11 +777,11 @@ * cache of the object name. */ if (flags & TCL_TRACE_RENAME) { if (oPtr->cachedNameObj) { - Tcl_DecrRefCount(oPtr->cachedNameObj); + TclDecrRefCount(oPtr->cachedNameObj); oPtr->cachedNameObj = NULL; } return; } @@ -1042,11 +1032,11 @@ if (clsPtr->filters.num) { Tcl_Obj *filterObj; FOREACH(filterObj, clsPtr->filters) { - Tcl_DecrRefCount(filterObj); + TclDecrRefCount(filterObj); } ckfree(clsPtr->filters.list); clsPtr->filters.num = 0; } @@ -1121,11 +1111,11 @@ if (i) { ckfree(oPtr->mixins.list); } FOREACH(filterObj, oPtr->filters) { - Tcl_DecrRefCount(filterObj); + TclDecrRefCount(filterObj); } if (i) { ckfree(oPtr->filters.list); } @@ -1136,11 +1126,11 @@ Tcl_DeleteHashTable(oPtr->methodsPtr); ckfree(oPtr->methodsPtr); } FOREACH(variableObj, oPtr->variables) { - Tcl_DecrRefCount(variableObj); + TclDecrRefCount(variableObj); } if (i) { ckfree(oPtr->variables.list); } @@ -1147,11 +1137,11 @@ if (oPtr->chainCache) { TclOODeleteChainCache(oPtr->chainCache); } if (oPtr->cachedNameObj) { - Tcl_DecrRefCount(oPtr->cachedNameObj); + TclDecrRefCount(oPtr->cachedNameObj); oPtr->cachedNameObj = NULL; } if (oPtr->metadataPtr != NULL) { Tcl_ObjectMetadataType *metadataTypePtr; @@ -1178,11 +1168,11 @@ ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } FOREACH(filterObj, clsPtr->filters) { - Tcl_DecrRefCount(filterObj); + TclDecrRefCount(filterObj); } if (i) { ckfree(clsPtr->filters.list); clsPtr->filters.num = 0; } @@ -1223,11 +1213,11 @@ Tcl_DeleteHashTable(&clsPtr->classMethods); TclOODelMethodRef(clsPtr->constructorPtr); TclOODelMethodRef(clsPtr->destructorPtr); FOREACH(variableObj, clsPtr->variables) { - Tcl_DecrRefCount(variableObj); + TclDecrRefCount(variableObj); } if (i) { ckfree(clsPtr->variables.list); } @@ -2488,11 +2478,11 @@ Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr); result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr, (Tcl_Class *) startClsPtr, mappedMethodName); if (result != TCL_OK) { - Tcl_DecrRefCount(mappedMethodName); + TclDecrRefCount(mappedMethodName); if (result == TCL_BREAK) { goto noMapping; } else if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (while mapping method name)"); } @@ -2504,11 +2494,11 @@ */ Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); - Tcl_DecrRefCount(mappedMethodName); + TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { Tcl_AppendResult(interp, "impossible to invoke method \"", TclGetString(methodNamePtr), "\": no defined method or unknown method", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED", Index: generic/tclOOBasic.c ================================================================== --- generic/tclOOBasic.c +++ generic/tclOOBasic.c @@ -17,10 +17,12 @@ #include "tclOOInt.h" static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp); static int AfterNRDestructor(ClientData data[], Tcl_Interp *interp, int result); +static int DecrRefsPostClassConstructor(ClientData data[], + Tcl_Interp *interp, int result); static int FinalizeConstruction(ClientData data[], Tcl_Interp *interp, int result); static int FinalizeEval(ClientData data[], Tcl_Interp *interp, int result); static int RestoreFrame(ClientData data[], @@ -64,10 +66,78 @@ return result; } Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); return TCL_OK; } + +/* + * ---------------------------------------------------------------------- + * + * TclOO_Class_Constructor -- + * + * Implementation for oo::class constructor. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Class_Constructor( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + Tcl_Obj *invoke[3]; + + if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "?definitionScript?"); + return TCL_ERROR; + } else if (objc == Tcl_ObjectContextSkippedArgs(context)) { + return TCL_OK; + } + + /* + * Delegate to [oo::define] to do the work. + */ + + invoke[0] = oPtr->fPtr->defineName; + invoke[1] = TclOOObjectName(interp, oPtr); + invoke[2] = objv[objc-1]; + + /* + * Must add references or errors in configuration script will cause + * trouble. + */ + + Tcl_IncrRefCount(invoke[0]); + Tcl_IncrRefCount(invoke[1]); + Tcl_IncrRefCount(invoke[2]); + TclNRAddCallback(interp, DecrRefsPostClassConstructor, + invoke[0], invoke[1], invoke[2], NULL); + + /* + * Tricky point: do not want the extra reported level in the Tcl stack + * trace, so use TCL_EVAL_NOERR. + */ + + return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL); +} + +static int +DecrRefsPostClassConstructor( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + TclDecrRefCount((Tcl_Obj *) data[0]); + TclDecrRefCount((Tcl_Obj *) data[1]); + TclDecrRefCount((Tcl_Obj *) data[2]); + return result; +} /* * ---------------------------------------------------------------------- * * TclOO_Class_Create -- @@ -1137,81 +1207,13 @@ */ Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr)); return TCL_OK; } - -/* - * ---------------------------------------------------------------------- - * - * TclOOUpcatchCmd -- - * - * Implementation of the [oo::UpCatch] command, which is a combination of - * [uplevel 1] and [catch] that makes it easier to write transparent - * error handling in scripts. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOUpcatchCmd( - ClientData ignored, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - return Tcl_NRCallObjProc(interp, TclOONRUpcatch, NULL, objc, objv); -} - -static int -UpcatchCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - CallFrame *savedFramePtr = data[0]; - Tcl_Obj *resultObj[2]; - int rewind = iPtr->execEnvPtr->rewind; - - iPtr->varFramePtr = savedFramePtr; - if (rewind || Tcl_LimitExceeded(interp)) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"UpCatch\" body line %d)", Tcl_GetErrorLine(interp))); - return TCL_ERROR; - } - resultObj[0] = Tcl_GetObjResult(interp); - resultObj[1] = Tcl_GetReturnOptions(interp, result); - Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj)); - return TCL_OK; -} - -int -TclOONRUpcatch( - ClientData ignored, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - CallFrame *savedFramePtr = iPtr->varFramePtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "script"); - return TCL_ERROR; - } - if (iPtr->varFramePtr->callerVarPtr != NULL) { - iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; - } - - Tcl_NRAddCallback(interp, UpcatchCallback, savedFramePtr, NULL,NULL,NULL); - return TclNREvalObjEx(interp, objv[1], TCL_EVAL_NOERR, - iPtr->cmdFramePtr, 1); -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclOODefineCmds.c ================================================================== --- generic/tclOODefineCmds.c +++ generic/tclOODefineCmds.c @@ -14,10 +14,17 @@ #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" +/* + * The maximum length of fully-qualified object name to use in an errorinfo + * message. Longer than this will be curtailed. + */ + +#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30 + /* * Some things that make it easier to declare a slot. */ struct DeclaredSlot { @@ -38,10 +45,12 @@ */ static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, Tcl_Namespace *const namespacePtr); +static void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, + Tcl_Obj *savedNameObj, const char *typeOfSubject); static inline Class * GetClassInOuterContext(Tcl_Interp *interp, Tcl_Obj *className, const char *errMsg); static inline int InitDefineContext(Tcl_Interp *interp, Tcl_Namespace *namespacePtr, Object *oPtr, int objc, Tcl_Obj *const objv[]); @@ -671,20 +680,28 @@ Tcl_Object TclOOGetDefineCmdContext( Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; + Tcl_Object object; if ((iPtr->varFramePtr == NULL) || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { Tcl_AppendResult(interp, "this command may only be called from within" " the context of an ::oo::define or ::oo::objdefine command", NULL); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return NULL; } - return (Tcl_Object) iPtr->varFramePtr->clientData; + object = iPtr->varFramePtr->clientData; + if (Tcl_ObjectDeleted(object)) { + Tcl_AppendResult(interp, "this command cannot be called when the " + "object has been deleted", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return NULL; + } + return object; } /* * ---------------------------------------------------------------------- * @@ -724,10 +741,48 @@ TclGetString(className), NULL); return NULL; } return oPtr->classPtr; } + +/* + * ---------------------------------------------------------------------- + * + * GenerateErrorInfo -- + * Factored out code to generate part of the error trace messages. + * + * ---------------------------------------------------------------------- + */ + +static void +GenerateErrorInfo( + Tcl_Interp *interp, /* Where to store the error info trace. */ + Object *oPtr, /* What object (or class) was being configured + * when the error occurred? */ + Tcl_Obj *savedNameObj, /* Name of object saved from before script was + * evaluated, which is needed if the object + * goes away part way through execution. OTOH, + * if the object isn't deleted then its + * current name (post-execution) has to be + * used. This matters, because the object + * could have been renamed... */ + const char *typeOfSubject) /* Part of the message, saying whether it was + * an object, class or class-as-object that + * was being configured. */ +{ + int length; + Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) + ? savedNameObj : TclOOObjectName(interp, oPtr); + const char *objName = Tcl_GetStringFromObj(realNameObj, &length); + int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in definition script for %s \"%.*s%s\" line %d)", + typeOfSubject, (overflow ? limit : length), objName, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); +} /* * ---------------------------------------------------------------------- * * TclOODefineObjCmd -- @@ -777,24 +832,19 @@ return TCL_ERROR; } AddRef(oPtr); if (objc == 3) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[2], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - int length; - const char *objName = Tcl_GetStringFromObj(objv[1], &length); - int limit = 60; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in definition script for object \"%.*s%s\" line %d)", - (overflow ? limit : length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); - } + GenerateErrorInfo(interp, oPtr, objNameObj, "class"); + } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; Tcl_Command cmd; int dummy; @@ -896,24 +946,19 @@ return TCL_ERROR; } AddRef(oPtr); if (objc == 3) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[2], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - int length; - const char *objName = Tcl_GetStringFromObj(objv[1], &length); - int limit = 60; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in definition script for object \"%.*s%s\" line %d)", - (overflow ? limit : length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); - } + GenerateErrorInfo(interp, oPtr, objNameObj, "object"); + } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; Tcl_Command cmd; int dummy; @@ -1015,25 +1060,19 @@ return TCL_ERROR; } AddRef(oPtr); if (objc == 2) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[1], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - int length; - const char *objName = Tcl_GetStringFromObj( - TclOOObjectName(interp, oPtr), &length); - int limit = 60; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in definition script for object \"%.*s%s\" line %d)", - (overflow ? limit : length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); - } + GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); + } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; Tcl_Command cmd; int dummy; Index: generic/tclOOInt.h ================================================================== --- generic/tclOOInt.h +++ generic/tclOOInt.h @@ -320,10 +320,11 @@ * constructor. */ Tcl_Obj *destructorName; /* Shared object containing the "name" of a * destructor. */ Tcl_Obj *clonedName; /* Shared object containing the name of a * "" pseudo-constructor. */ + Tcl_Obj *defineName; /* Fully qualified name of oo::define. */ } Foundation; /* * A call context structure is built when a method is called. They contain the * chain of method implementations that are to be invoked by a particular @@ -451,10 +452,13 @@ /* * Method implementations (in tclOOBasic.c). */ +MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Class_Create(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, @@ -517,12 +521,10 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); -MODULE_SCOPE int TclOONRUpcatch(ClientData ignored, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, @@ -530,13 +532,10 @@ MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, CallChain *callPtr); MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, CallContext *contextPtr); MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); -MODULE_SCOPE int TclOOUpcatchCmd(ClientData ignored, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); /* * Include all the private API, generated from tclOO.decls. */ Index: generic/tclOOMethod.c ================================================================== --- generic/tclOOMethod.c +++ generic/tclOOMethod.c @@ -1202,19 +1202,10 @@ Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; int objectNameLen; - if (Tcl_GetErrorLine(interp) == (int) 0xDEADBEEF) { - /* - * Horrible hack to deal with certain constructors that must not add - * information to the error trace. - */ - - return; - } - if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; kindName = "object"; } else { if (mPtr->declaringClassPtr == NULL) { Index: generic/tclPathObj.c ================================================================== --- generic/tclPathObj.c +++ generic/tclPathObj.c @@ -1085,11 +1085,11 @@ } } if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - length++; + Tcl_GetStringFromObj(res, &length); } Tcl_SetObjLength(res, length + (int) strlen(strElt)); ptr = TclGetString(res) + length; for (; *strElt != '\0'; strElt++) { Index: generic/tclPlatDecls.h ================================================================== --- generic/tclPlatDecls.h +++ generic/tclPlatDecls.h @@ -44,23 +44,11 @@ /* * Exported function declarations: */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ -/* 0 */ -EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, - const char *bundleName, int hasResourceFile, - int maxPathLen, char *libraryPath); -/* 1 */ -EXTERN int Tcl_MacOSXOpenVersionedBundleResources( - Tcl_Interp *interp, const char *bundleName, - const char *bundleVersion, - int hasResourceFile, int maxPathLen, - char *libraryPath); -#endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr); /* 1 */ EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len, @@ -81,15 +69,11 @@ typedef struct TclPlatStubs { int magic; const struct TclPlatStubHooks *hooks; -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ - int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */ - int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */ -#endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */ @@ -109,17 +93,11 @@ /* * Inline function declarations: */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ -#define Tcl_MacOSXOpenBundleResources \ - (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ -#define Tcl_MacOSXOpenVersionedBundleResources \ - (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ -#endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ #define Tcl_WinUtfToTChar \ (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ #define Tcl_WinTCharToUtf \ (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */ #endif /* WIN */ Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -163,14 +163,10 @@ } return Tcl_ExternalToUtfDString(winTCharEncoding, string, len, dsPtr); } -#define Tcl_MacOSXOpenBundleResources (int (*) ( \ - Tcl_Interp *, const char *, int, int, char *)) Tcl_WinUtfToTChar -#define Tcl_MacOSXOpenVersionedBundleResources (int (*) ( \ - Tcl_Interp *, const char *, const char *, int, int, char *)) Tcl_WinTCharToUtf #define TclMacOSXGetFileAttribute (int (*) (Tcl_Interp *, \ int, Tcl_Obj *, Tcl_Obj **)) TclpCreateProcess #define TclMacOSXMatchType (int (*) (Tcl_Interp *, const char *, \ const char *, Tcl_StatBuf *, Tcl_GlobTypeData *)) TclpMakeFile #define TclMacOSXNotifierAddRunLoopMode (void (*) (const void *)) TclpOpenFile @@ -592,15 +588,11 @@ }; static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ - Tcl_MacOSXOpenBundleResources, /* 0 */ - Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ -#endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_MacOSXOpenBundleResources, /* 0 */ Index: library/dde/pkgIndex.tcl ================================================================== --- library/dde/pkgIndex.tcl +++ library/dde/pkgIndex.tcl @@ -1,6 +1,6 @@ -if {![package vsatisfies [package provide Tcl] 8.4]} return +if {![package vsatisfies [package provide Tcl] 8.5]} return if {[string compare [info sharedlibextension] .dll]} return if {[::tcl::pkgconfig get debug]} { package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde] } else { package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde] Index: library/safe.tcl ================================================================== --- library/safe.tcl +++ library/safe.tcl @@ -463,12 +463,22 @@ } # This alias lets the slave have access to a subset of the 'file' # command functionality. - AliasSubset $slave file \ - file dir.* join root.* ext.* tail path.* split + ::interp expose $slave file + foreach subcommand {dirname extension rootname tail} { + ::interp alias $slave ::tcl::file::$subcommand {} file $subcommand + } + foreach subcommand { + atime attributes copy delete executable exists isdirectory isfile + link lstat mtime mkdir nativename normalize owned readable readlink + rename size stat tempfile type volumes writable + } { + ::interp alias $slave ::tcl::file::$subcommand {} \ + ::safe::BadSubcommand $slave file $subcommand + } # Subcommands of info foreach {subcommand alias} { nameofexecutable AliasExeName } { @@ -497,11 +507,12 @@ # Sync the paths used to search for Tcl modules. This can be done only # now, after tm.tcl was loaded. namespace upvar ::safe S$slave state if {[llength $state(tm_path_slave)] > 0} { - ::interp eval $slave [list ::tcl::tm::add {*}$state(tm_path_slave)] + ::interp eval $slave [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] } return $slave } # Add (only if needed, avoid duplicates) 1 level of sub directories to an @@ -677,13 +688,13 @@ -tails 0 -- 0 } if {$::tcl_platform(platform) eq "windows"} { - set dirPartRE {^(.*)[\\/]} + set dirPartRE {^(.*)[\\/]([^\\/]*)$} } else { - set dirPartRE {^(.*)/} + set dirPartRE {^(.*)/([^/]*)$} } set dir {} set virtualdir {} @@ -732,13 +743,11 @@ try { set dir [TranslatePath $slave $virtualdir] DirInAccessPath $slave $dir } on error msg { Log $slave $msg - if {$got(-nocomplain)} { - return - } + if {$got(-nocomplain)} return return -code error "permission denied" } lappend cmd -directory $dir } @@ -747,24 +756,35 @@ set args [lreplace $args $at end [join [lrange $args $at end] "/"]] } # Process remaining pattern arguments set firstPattern [llength $cmd] - while {$at < [llength $args]} { - set opt [lindex $args $at] - incr at - if {[regexp $dirPartRE $opt -> thedir]} { - try { - set thedir [file join $virtualdir $thedir] - DirInAccessPath $slave [TranslatePath $slave $thedir] - } on error msg { - Log $slave $msg - if {$got(-nocomplain)} { - continue - } - return -code error "permission denied" - } + foreach opt [lrange $args $at end] { + if {![regexp $dirPartRE $opt -> thedir thefile]} { + set thedir . + } + if {$thedir eq "*" && + ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} { + set mapped 0 + foreach d [glob -directory [TranslatePath $slave $virtualdir] \ + -types d -tails *] { + catch { + DirInAccessPath $slave \ + [TranslatePath $slave [file join $virtualdir $d]] + lappend cmd [file join $d $thefile] + set mapped 1 + } + } + if {$mapped} continue + } + try { + DirInAccessPath $slave [TranslatePath $slave \ + [file join $virtualdir $thedir]] + } on error msg { + Log $slave $msg + if {$got(-nocomplain)} continue + return -code error "permission denied" } lappend cmd $opt } Log $slave "GLOB = $cmd" NOTICE @@ -777,11 +797,11 @@ } on error msg { Log $slave $msg return -code error "script error" } - Log $slave "GLOB @ $entries" NOTICE + Log $slave "GLOB < $entries" NOTICE # Translate path back to what the slave should see. set res {} set l [string length $dir] foreach p $entries { @@ -789,11 +809,11 @@ set p [string replace $p 0 [expr {$l-1}] $virtualdir] } lappend res $p } - Log $slave "GLOB @ $res" NOTICE + Log $slave "GLOB > $res" NOTICE return $res } # AliasSource is the target of the "source" alias in safe interpreters. @@ -978,62 +998,37 @@ if {$norm_dir ni $state(access_path,norm)} { return -code error "\"$dir\": not in access_path" } } -# This procedure enables access from a safe interpreter to only a subset -# of the subcommands of a command: - -proc ::safe::Subset {slave command okpat args} { - set subcommand [lindex $args 0] - if {[regexp $okpat $subcommand]} { - return [$command {*}$args] - } +# This procedure is used to report an attempt to use an unsafe member of an +# ensemble command. + +proc ::safe::BadSubcommand {slave command subcommand args} { set msg "not allowed to invoke subcommand $subcommand of $command" Log $slave $msg - return -code error $msg -} - -# This procedure installs an alias in a slave that invokes "safesubset" in -# the master to execute allowed subcommands. It precomputes the pattern of -# allowed subcommands; you can use wildcards in the pattern if you wish to -# allow subcommand abbreviation. -# -# Syntax is: AliasSubset slave alias target subcommand1 subcommand2... - -proc ::safe::AliasSubset {slave alias target args} { - set pat "^([join $args |])\$" - ::interp alias $slave $alias {}\ - [namespace current]::Subset $slave $target $pat + return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg } # AliasEncoding is the target of the "encoding" alias in safe interpreters. proc ::safe::AliasEncoding {slave option args} { - # Careful; do not want empty option to get through to the [string equal] - if {[regexp {^(name.*|convert.*|)$} $option]} { - return [::interp invokehidden $slave encoding $option {*}$args] - } - - if {[string equal -length [string length $option] $option "system"]} { - if {![llength $args]} { - # passed all the tests , lets source it: - try { - return [::interp invokehidden $slave encoding system] - } on error msg { - Log $slave $msg - return -code error "script error" - } - } - set msg "wrong # args: should be \"encoding system\"" - set code {TCL WRONGARGS} - } else { - set msg "bad option \"$option\": must be convertfrom, convertto, names, or system" - set code [list TCL LOOKUP INDEX option $option] - } - Log $slave $msg - return -code error -errorcode $code $msg + # Note that [encoding dirs] is not supported in safe slaves at all + set subcommands {convertfrom convertto names system} + try { + set option [tcl::prefix match -error [list -level 1 -errorcode \ + [list TCL LOOKUP INDEX option $option]] $subcommands $option] + # Special case: [encoding system] ok, but [encoding system foo] not + if {$option eq "system" && [llength $args]} { + return -code error -errorcode {TCL WRONGARGS} \ + "wrong # args: should be \"encoding system\"" + } + } on error {msg options} { + Log $slave $msg + return -options $options $msg + } + tailcall ::interp invokehidden $slave encoding $option {*}$args } # Various minor hiding of platform features. [Bug 2913625] proc ::safe::AliasExeName {slave} { Index: tests/all.tcl ================================================================== --- tests/all.tcl +++ tests/all.tcl @@ -8,10 +8,11 @@ # Copyright (c) 2000 by Ajuba Solutions # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +package prefer latest package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] runAllTests Index: tests/dict.test ================================================================== --- tests/dict.test +++ tests/dict.test @@ -1473,11 +1473,11 @@ proc linenumber {} { dict get [info frame -1] line } test dict-23.1 {dict compilation crash: Bug 3487626} { - apply {n { + apply {{} {apply {n { set e {} set k {} dict for {a b} {c {d {e {f g}}}} { ::tcl::dict::for {h i} $b { dict update i e j { @@ -1485,18 +1485,18 @@ return [expr {$n - [linenumber]}] } } } } - }} [linenumber] + }} [linenumber]}} } 5 test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are # confusing things. - apply {n { + apply {{} {apply {n { set e {} set k {} dict for {a { b }} {c {d {e {f g}}}} { @@ -1516,11 +1516,11 @@ return [expr {$n - [linenumber]}] } } } } - }} [linenumber] + }} [linenumber]}} } 5 rename linenumber {} # cleanup ::tcltest::cleanupTests Index: tests/oo.test ================================================================== --- tests/oo.test +++ tests/oo.test @@ -1972,11 +1972,11 @@ 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" - (in definition script for object "oo::object" line 1) + (in definition script for class "::oo::object" line 1) invoked from within "oo::define oo::object {error foo}"}} test oo-18.2 {OO: define command support} { list [catch {oo::define oo::object error foo} msg] $msg $errorInfo } {1 foo {foo @@ -1985,21 +1985,21 @@ test oo-18.3 {OO: define command support} { list [catch {oo::class create foo {error bar}} msg] $msg $errorInfo } {1 bar {bar while executing "error bar" - (in definition script for object "::foo" line 1) + (in definition script for class "::foo" line 1) invoked from within "oo::class create foo {error bar}"}} test oo-18.3a {OO: define command support} { list [catch {oo::class create foo { error bar }} msg] $msg $errorInfo } {1 bar {bar while executing "error bar" - (in definition script for object "::foo" line 2) + (in definition script for class "::foo" line 2) invoked from within "oo::class create foo { error bar }"}} test oo-18.3b {OO: define command support} { @@ -2013,11 +2013,11 @@ invoked from within "eval error bar" ("eval" body line 1) invoked from within "eval eval error bar" - (in definition script for object "::foo" line 2) + (in definition script for class "::foo" line 2) invoked from within "oo::class create foo { eval eval error bar }"}} test oo-18.4 {OO: more error traces from the guts} -setup { @@ -2068,10 +2068,110 @@ invoked from within "next $script" (class "::cls" method "eval" line 1) invoked from within "obj eval {error bar}"}} +test oo-18.6 {class construction reference management and errors} -setup { + oo::class create super_abc +} -body { + catch { +oo::class create abc { + superclass super_abc + ::rename abc ::def + ::error foo +} + } msg opt + dict get $opt -errorinfo +} -cleanup { + super_abc destroy +} -result {foo + while executing +"::error foo" + (in definition script for class "::def" line 4) + invoked from within +"oo::class create abc { + superclass super_abc + ::rename abc ::def + ::error foo +}"} +test oo-18.7 {OO: objdefine command support} -setup { + oo::object create ::inst +} -body { + list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo +} -cleanup { + catch {::inst destroy} + catch {::INST destroy} +} -result {1 foo {foo + while executing +"error foo" + (in definition script for object "::INST" line 1) + invoked from within +"oo::objdefine inst {rename ::inst ::INST;error foo}"}} +test oo-18.8 {OO: define/self command support} -setup { + oo::class create master + oo::class create ::foo {superclass master} +} -body { + catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {foobar + while executing +"error foobar" + (in definition script for class object "::bar" line 1) + invoked from within +"self {error foobar}" + (in definition script for class "::bar" line 1) + invoked from within +"oo::define foo {rename ::foo ::bar; self {error foobar}}"} +test oo-18.9 {OO: define/self command support} -setup { + oo::class create master + set c [oo::class create now_this_is_a_very_very_long_class_name_indeed { + superclass master + }] +} -body { + catch {oo::define $c {error err}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {err + while executing +"error err" + (in definition script for class "::now_this_is_a_very_very_long..." line 1) + invoked from within +"oo::define $c {error err}"} +test oo-18.10 {OO: define/self command support} -setup { + oo::class create master + oo::class create ::foo {superclass master} +} -body { + catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {foobar + while executing +"error foobar" + (in definition script for class object "::foo" line 1) + invoked from within +"self {rename ::foo {}; error foobar}" + (in definition script for class "::foo" line 1) + invoked from within +"oo::define foo {self {rename ::foo {}; error foobar}}"} +test oo-18.11 {OO: define/self command support} -setup { + oo::class create master + oo::class create ::foo {superclass master} +} -body { + catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {this command cannot be called when the object has been deleted + while executing +"self {error foobar}" + (in definition script for class "::foo" line 1) + invoked from within +"oo::define foo {rename ::foo {}; self {error foobar}}"} test oo-19.1 {OO: varname method} -setup { oo::object create inst oo::objdefine inst export eval set result {} @@ -3187,11 +3287,11 @@ } -body { list [$s destroy; $s unknown] [$s contents] } -cleanup { rename $s {} } -result {{} {a b c destroy unknown}} -test oo-32.3 {TIP 380: slots - defaulting} -setup { +test oo-33.3 {TIP 380: slots - defaulting} -setup { set s [SampleSlot new] } -body { oo::objdefine $s forward --default-operation my -set list [$s destroy; $s unknown] [$s contents] [$s ops] } -cleanup { Index: tests/safe.test ================================================================== --- tests/safe.test +++ tests/safe.test @@ -25,13 +25,11 @@ set ::auto_path [info library] # Force actual loading of the safe package because we use un exported (and # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} - -proc equiv {x} {return $x} - + # testing that nested and statics do what is advertised (we use a static # package - Tcltest - but it might be absent if we're in standard tclsh) testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] @@ -92,11 +90,11 @@ } -body { safe::interpCreate a lsort [a aliases] } -cleanup { safe::interpDelete a -} -result {::tcl::info::nameofexecutable clock encoding exit file glob load source} +} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source} test safe-3.3 {calling safe::interpCreate on trusted interp} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a interp eval a {source [file join $tcl_library init.tcl]} @@ -536,15 +534,158 @@ } -result {} test safe-12.7 {glob is restricted} -setup { set i [safe::interpCreate] } -body { $i eval glob * +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {permission denied} + +proc buildEnvironment {filename} { + upvar 1 testdir testdir testdir2 testdir2 testfile testfile + set testdir [makeDirectory deletethisdir] + set testdir2 [makeDirectory deletemetoo $testdir] + set testfile [makeFile {} $filename $testdir2] +} +#### New tests for Safe base glob, with patches @ Bug 2964715 +test safe-13.1 {glob is restricted [Bug 2964715]} -setup { + set i [safe::interpCreate] +} -body { + $i eval glob * +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {permission denied} +test safe-13.2 {mimic the valid glob call by ::tcl::tm::UnknownHandler [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment deleteme.tm +} -body { + ::safe::interpAddToAccessPath $i $testdir2 + set result [$i eval glob -nocomplain -directory $testdir2 *.tm] + if {$result eq [list $testfile]} { + return "glob match" + } else { + return "no match: $result" + } +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {glob match} +test safe-13.3 {cf 13.2 but test glob failure when -directory is outside access path [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment deleteme.tm +} -body { + $i eval glob -directory $testdir2 *.tm +} -returnCodes error -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {permission denied} +test safe-13.4 {another valid glob call [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment deleteme.tm +} -body { + ::safe::interpAddToAccessPath $i $testdir + ::safe::interpAddToAccessPath $i $testdir2 + set result [$i eval \ + glob -nocomplain -directory $testdir [file join deletemetoo *.tm]] + if {$result eq [list $testfile]} { + return "glob match" + } else { + return "no match: $result" + } +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {glob match} +test safe-13.5 {as 13.4 but test glob failure when -directory is outside access path [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment deleteme.tm +} -body { + ::safe::interpAddToAccessPath $i $testdir2 + $i eval \ + glob -directory $testdir [file join deletemetoo *.tm] +} -returnCodes error -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {permission denied} +test safe-13.6 {as 13.4 but test silent failure when result is outside access_path [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment deleteme.tm +} -body { + ::safe::interpAddToAccessPath $i $testdir + $i eval \ + glob -nocomplain -directory $testdir [file join deletemetoo *.tm] +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {} +test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment pkgIndex.tcl +} -body { + set safeTD [::safe::interpAddToAccessPath $i $testdir] + ::safe::interpAddToAccessPath $i $testdir2 + string map [list $safeTD EXPECTED] [$i eval [list \ + glob -directory $safeTD -join * pkgIndex.tcl]] +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}} +# Note the extra {} around the result above; that's *expected* because of the +# format of virtual path roots. +test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment notIndex.tcl +} -body { + set safeTD [::safe::interpAddToAccessPath $i $testdir] + ::safe::interpAddToAccessPath $i $testdir2 + $i eval [list glob -directory $safeTD -join -nocomplain * notIndex.tcl] +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {} +test safe-13.9 {as 13.8 but test glob failure when -directory is outside access path [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment notIndex.tcl +} -body { + ::safe::interpAddToAccessPath $i $testdir2 + set result [$i eval \ + glob -directory $testdir -join -nocomplain * notIndex.tcl] + if {$result eq [list $testfile]} { + return {glob match} + } else { + return "no match: $result" + } +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {no match: } +test safe-13.10 {as 13.8 but test silent failure when result is outside access_path [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment notIndex.tcl +} -body { + ::safe::interpAddToAccessPath $i $testdir + $i eval glob -directory $testdir -join -nocomplain * notIndex.tcl +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {} +rename buildEnvironment {} + +#### Test for the module path +test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup { + set i [safe::interpCreate] +} -body { + set tm {} + foreach token [$i eval ::tcl::tm::path list] { + lappend tm [dict get [set ::safe::S${i}(access_path,map)] $token] + } + return $tm } -cleanup { safe::interpDelete $i -} -match glob -result * +} -result [::tcl::tm::path list] -test safe-13.1 {safe file ensemble does not surprise code} -setup { +test safe-15.1 {safe file ensemble does not surprise code} -setup { set i [interp create -safe] } -body { set result [expr {"file" in [interp hidden $i]}] lappend result [interp eval $i {tcl::file::split a/b/c}] lappend result [catch {interp eval $i {tcl::file::isdirectory .}}] @@ -554,15 +695,15 @@ interp expose $i file lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg } -cleanup { interp delete $i -} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {invalid command name "::tcl::file::isdirectory"}} +} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} set ::auto_path $saveAutoPath # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/socket.test ================================================================== --- tests/socket.test +++ tests/socket.test @@ -62,11 +62,11 @@ package require tcltest 2 namespace import -force ::tcltest::* # Some tests require the Thread package or exec command -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.6.6}]}] testConstraint exec [llength [info commands exec]] # Produce a random port number in the Dynamic/Private range # from 49152 through 65535. proc randport {} { expr {int(rand()*16383+49152)} } Index: tests/switch.test ================================================================== --- tests/switch.test +++ tests/switch.test @@ -534,19 +534,19 @@ list [catch {switch -regexp -matchvar x(x) -- abc . {set x}} msg] $x $msg } {1 {} {can't set "x(x)": variable isn't array}} test switch-12.1 {regexp matching with -indexvar} { switch -regexp -indexvar x -- abc {.(.). {set x}} -} {{0 3} {1 2}} +} {{0 2} {1 1}} test switch-12.2 {regexp matching with -indexvar} { set x GOOD switch -regexp -indexvar x -- abc {.(.).. {list $x z}} set x } GOOD test switch-12.3 {regexp matching with -indexvar} { switch -regexp -indexvar x -- "a b c" {.(.). {set x}} -} {{0 3} {1 2}} +} {{0 2} {1 1}} test switch-12.4 {regexp matching with -indexvar} { set x BAD switch -regexp -indexvar x -- "a b c" { bc {list $x YES} default {list $x NO} @@ -558,26 +558,36 @@ } {1 {} {-indexvar option requires -regexp option}} test switch-12.6 {-indexvar unwritable} { set x {} list [catch {switch -regexp -indexvar x(x) -- abc . {set x}} msg] $x $msg } {1 {} {can't set "x(x)": variable isn't array}} +test switch-12.7 {[Bug 3106532] -indexvar should be directly usable with [string range]} { + set str abcdef + switch -regexp -indexvar x -- $str ^... {string range $str {*}[lindex $x 0]} +} abc +test switch-12.8 {-indexvar and matched empty strings} { + switch -regexp -indexvar x -- abcdef ^...(x?) {return $x} +} {{0 2} {3 2}} +test switch-12.9 {-indexvar and unmatched strings} { + switch -regexp -indexvar x -- abcdef ^...(x)? {return $x} +} {{0 2} {-1 -1}} test switch-13.1 {-indexvar -matchvar combinations} { switch -regexp -indexvar x -matchvar y abc { . {list $x $y} } -} {{{0 1}} a} +} {{{0 0}} a} test switch-13.2 {-indexvar -matchvar combinations} { switch -regexp -indexvar x -matchvar y abc { .$ {list $x $y} } -} {{{2 3}} c} +} {{{2 2}} c} test switch-13.3 {-indexvar -matchvar combinations} { switch -regexp -indexvar x -matchvar y abc { (.)(.)(.) {list $x $y} } -} {{{0 3} {0 1} {1 2} {2 3}} {abc a b c}} +} {{{0 2} {0 0} {1 1} {2 2}} {abc a b c}} test switch-13.4 {-indexvar -matchvar combinations} { set x - set y - switch -regexp -indexvar x -matchvar y abc { (.)(.)(.). - @@ -595,11 +605,11 @@ set x - set y - list [catch { switch -regexp -indexvar x -matchvar y(y) abc {. {list $x $y}} } msg] $x $y $msg -} {1 {{0 1}} - {can't set "y(y)": variable isn't array}} +} {1 {{0 0}} - {can't set "y(y)": variable isn't array}} test switch-14.1 {-regexp -- compilation [Bug 1854399]} { switch -regexp -- 0 { {[0-9]+} {return yes} default {return no} Index: tests/zlib.test ================================================================== --- tests/zlib.test +++ tests/zlib.test @@ -145,10 +145,11 @@ after 1000 {set total timeout} fcopy $sin $fout -command {apply {{c {e {}}} { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait total + after cancel {set total timeout} } finally { close $sin } append total --> [file size $file] } -cleanup { @@ -224,10 +225,11 @@ after 1000 {set ::total timeout} fcopy $sin $fout -command {apply {{c {e {}}} { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait ::total + after cancel {set ::total timeout} close $sin; close $fout list read $::total size [file size $file] } -cleanup { close $srv removeFile $file @@ -249,10 +251,11 @@ after 1000 {set ::total timeout} fcopy $sin $fout -command {apply {{c {e {}}} { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait ::total + after cancel {set ::total timeout} close $sin; close $fout list read $::total size [file size $file] } -cleanup { close $srv removeFile $file @@ -282,10 +285,11 @@ update set fout [open $file wb] after 1000 {set ::total timeout} fcopy $sin $fout -size 8192 -command [list zlib95copy $sin $fout 0] vwait ::total + after cancel {set ::total timeout} close $sin; close $fout list $::total size [file size $file] } -cleanup { close $srv rename zlib95copy {} @@ -310,10 +314,11 @@ chan event $s readable {} set ::total [list eof [string length $d]] } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { close $srv unset -nocomplain total @@ -337,10 +342,11 @@ chan event $s readable {} set ::total [list eof [string length $d]] } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { close $srv unset -nocomplain total @@ -364,10 +370,11 @@ chan event $s readable {} set ::total [list eof [string length $d]] } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { unset -nocomplain total close $srv @@ -394,10 +401,11 @@ set ::total [list eof [string length $d]] } }} $s] vwait ::total } finally { + after cancel {set ::total timeout} close $s } set ::total } -cleanup { unset -nocomplain total @@ -426,10 +434,11 @@ set ::total [list eof [string length $d]] } }} $s] vwait ::total } finally { + after cancel {set ::total timeout} close $s } set ::total } -cleanup { unset -nocomplain total @@ -458,10 +467,11 @@ set ::total [list eof [string length $d]] } }} $s] vwait ::total } finally { + after cancel {set ::total timeout} close $s } set ::total } -cleanup { unset -nocomplain total @@ -500,10 +510,12 @@ puts $s test chan close $s after 100 {set ::total done} }} $s] vwait ::total + after cancel {set ::total timeout} + after cancel {set ::total done} set ::total } -cleanup { close $srv rename bgerror {} } -returnCodes error \ @@ -536,10 +548,12 @@ puts $s test chan close $s after 100 {set ::total done} }} $s] vwait ::total + after cancel {set ::total timeout} + after cancel {set ::total done} set ::total } -cleanup { close $srv rename bgerror {} rename zlibRead {} @@ -574,10 +588,12 @@ puts $s test chan close $s after 100 {set ::total done} }} $s] vwait ::total + after cancel {set ::total timeout} + after cancel {set ::total done} set ::total } -cleanup { close $srv rename bgerror {} rename zlibRead {} Index: tools/genStubs.tcl ================================================================== --- tools/genStubs.tcl +++ tools/genStubs.tcl @@ -566,12 +566,12 @@ set text " " if {$args eq ""} { append text $rtype " *" $lfname "; /* $index */\n" return $text } - if {[string range $rtype end-7 end] eq "CALLBACK"} { - append text [string trim [string range $rtype 0 end-8]] " (CALLBACK *" $lfname ") " + if {[string range $rtype end-8 end] eq "__stdcall"} { + append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") " } else { append text $rtype " (*" $lfname ") " } set arg1 [lindex $args 0] switch -exact $arg1 { Index: win/configure ================================================================== --- win/configure +++ win/configure @@ -307,11 +307,11 @@ #endif #if HAVE_UNISTD_H # include #endif" -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING ZLIB_DLL_FILE ZLIB_LIBS ZLIB_OBJS CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_EXE TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_DDE_PATCH_LEVEL TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION TCL_REG_PATCH_LEVEL RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING ZLIB_DLL_FILE ZLIB_LIBS ZLIB_OBJS CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_EXE TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. ac_init_help= ac_init_version=false @@ -1312,20 +1312,18 @@ TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 TCL_PATCH_LEVEL="b2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.3 +TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 -TCL_DDE_PATCH_LEVEL="0" DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION TCL_REG_VERSION=1.3 TCL_REG_MAJOR_VERSION=1 TCL_REG_MINOR_VERSION=3 -TCL_REG_PATCH_LEVEL="0" REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION PKG_CFG_ARGS=$@ #------------------------------------------------------------------------ @@ -5253,12 +5251,10 @@ - - ac_config_files="$ac_config_files Makefile tclConfig.sh tcl.hpj" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. @@ -5983,15 +5979,13 @@ s,@TCL_LIB_VERSIONS_OK@,$TCL_LIB_VERSIONS_OK,;t t s,@TCL_PACKAGE_PATH@,$TCL_PACKAGE_PATH,;t t s,@TCL_DDE_VERSION@,$TCL_DDE_VERSION,;t t s,@TCL_DDE_MAJOR_VERSION@,$TCL_DDE_MAJOR_VERSION,;t t s,@TCL_DDE_MINOR_VERSION@,$TCL_DDE_MINOR_VERSION,;t t -s,@TCL_DDE_PATCH_LEVEL@,$TCL_DDE_PATCH_LEVEL,;t t s,@TCL_REG_VERSION@,$TCL_REG_VERSION,;t t s,@TCL_REG_MAJOR_VERSION@,$TCL_REG_MAJOR_VERSION,;t t s,@TCL_REG_MINOR_VERSION@,$TCL_REG_MINOR_VERSION,;t t -s,@TCL_REG_PATCH_LEVEL@,$TCL_REG_PATCH_LEVEL,;t t s,@RC_OUT@,$RC_OUT,;t t s,@RC_TYPE@,$RC_TYPE,;t t s,@RC_INCLUDE@,$RC_INCLUDE,;t t s,@RC_DEFINE@,$RC_DEFINE,;t t s,@RC_DEFINES@,$RC_DEFINES,;t t Index: win/configure.in ================================================================== --- win/configure.in +++ win/configure.in @@ -15,20 +15,18 @@ TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 TCL_PATCH_LEVEL="b2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.3 +TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 -TCL_DDE_PATCH_LEVEL="0" DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION TCL_REG_VERSION=1.3 TCL_REG_MAJOR_VERSION=1 TCL_REG_MINOR_VERSION=3 -TCL_REG_PATCH_LEVEL="0" REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION PKG_CFG_ARGS=$@ #------------------------------------------------------------------------ @@ -428,15 +426,13 @@ # win only AC_SUBST(TCL_DDE_VERSION) AC_SUBST(TCL_DDE_MAJOR_VERSION) AC_SUBST(TCL_DDE_MINOR_VERSION) -AC_SUBST(TCL_DDE_PATCH_LEVEL) AC_SUBST(TCL_REG_VERSION) AC_SUBST(TCL_REG_MAJOR_VERSION) AC_SUBST(TCL_REG_MINOR_VERSION) -AC_SUBST(TCL_REG_PATCH_LEVEL) AC_SUBST(RC) AC_SUBST(RC_OUT) AC_SUBST(RC_TYPE) AC_SUBST(RC_INCLUDE) Index: win/makefile.bc ================================================================== --- win/makefile.bc +++ win/makefile.bc @@ -124,12 +124,12 @@ NAMEPREFIX = tcl STUBPREFIX = $(NAMEPREFIX)stub DOTVERSION = 8.6 VERSION = 86 -DDEVERSION = 13 -DDEDOTVERSION = 1.3 +DDEVERSION = 14 +DDEDOTVERSION = 1.4 REGVERSION = 13 REGDOTVERSION = 1.3 BINROOT = .. Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -184,11 +184,11 @@ STUBPREFIX = $(PROJECT)stub DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) -DDEDOTVERSION = 1.3 +DDEDOTVERSION = 1.4 DDEVERSION = $(DDEDOTVERSION:.=) REGDOTVERSION = 1.3 REGVERSION = $(REGDOTVERSION:.=) Index: win/tclWinDde.c ================================================================== --- win/tclWinDde.c +++ win/tclWinDde.c @@ -771,10 +771,11 @@ * Execute this script. The results will be saved into a list object * which will be retreived later. See ExecuteRemoteObject. */ Tcl_Obj *returnPackagePtr; + Tcl_UniChar *uniStr; for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { /* * Empty loop body. @@ -783,13 +784,26 @@ if (convPtr == NULL) { return (HDDEDATA) DDE_FNOTPROCESSED; } - utilString = (TCHAR *) DdeAccessData(hData, &dlen); - len = dlen; - ddeObjectPtr = Tcl_NewStringObj(utilString, -1); + utilString = (char *) DdeAccessData(hData, &dlen); + uniStr = (Tcl_UniChar *) utilString; + if (!dlen) { + /* Empty string. Just for protection against crash. */ + ddeObjectPtr = Tcl_NewObj(); + } else if ((dlen & 1) || uniStr[(dlen>>1)-1]) { + /* Cannot be unicode, so assume utf-8 */ + if (!utilString[dlen-1]) { + dlen--; + } + ddeObjectPtr = Tcl_NewStringObj(utilString, dlen); + } else { + /* unicode */ + dlen >>= 1; + ddeObjectPtr = Tcl_NewUnicodeObj(uniStr, dlen); + } Tcl_IncrRefCount(ddeObjectPtr); DdeUnaccessData(hData); if (convPtr->returnPackagePtr != NULL) { Tcl_DecrRefCount(convPtr->returnPackagePtr); } @@ -1385,22 +1399,22 @@ } break; case DDE_EXECUTE: { int dataLength; - BYTE *dataString; + const Tcl_UniChar *dataString; if (binary) { - dataString = (BYTE *) + dataString = (const Tcl_UniChar *) Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); } else { - dataString = (BYTE *) - Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength); - dataLength += 1; + dataString = + Tcl_GetUnicodeFromObj(objv[firstArg + 2], &dataLength); + dataLength = (dataLength + 1) * sizeof(Tcl_UniChar); } - if (dataLength <= (binary ? 0 : sizeof(TCHAR))) { + if (dataLength <= (binary ? 0 : sizeof(Tcl_UniChar))) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot execute null data", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; break; @@ -1413,20 +1427,20 @@ SetDdeError(interp); result = TCL_ERROR; break; } - ddeData = DdeCreateDataHandle(ddeInstance, dataString, - (DWORD) dataLength, 0, 0, CF_TEXT, 0); + ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString, + (DWORD) dataLength, 0, 0, binary ? CF_TEXT : CF_UNICODETEXT, 0); if (ddeData != NULL) { if (async) { DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + binary ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, - hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL); + hConv, 0, binary ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeReturn == 0) { SetDdeError(interp); result = TCL_ERROR; } } @@ -1459,23 +1473,28 @@ Tcl_Obj *returnObjPtr; ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, - CF_TEXT, XTYP_REQUEST, 5000, NULL); + binary ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { DWORD tmp; - const BYTE *dataString = DdeAccessData(ddeData, &tmp); + const Tcl_UniChar *dataString = (const Tcl_UniChar *) DdeAccessData(ddeData, &tmp); if (binary) { returnObjPtr = - Tcl_NewByteArrayObj(dataString, (int) tmp); + Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); } else { - returnObjPtr = Tcl_NewStringObj((char *)dataString, -1); + tmp >>= 1; + if (tmp && !dataString[(tmp-1)]) { + --tmp; + } + returnObjPtr = Tcl_NewUnicodeObj(dataString, + (int) tmp); } DdeUnaccessData(ddeData); DdeFreeDataHandle(ddeData); Tcl_SetObjResult(interp, returnObjPtr); } @@ -1518,11 +1537,11 @@ } else { ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(dataString, (DWORD) length, - hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL); + hConv, ddeItem, binary ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; } } else { @@ -1661,28 +1680,28 @@ result = TCL_ERROR; goto cleanup; } objPtr = Tcl_ConcatObj(objc, objv); - string = Tcl_GetStringFromObj(objPtr, &length); + string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length); ddeItemData = DdeCreateDataHandle(ddeInstance, - (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0); + (BYTE *) string, (DWORD) (2*length+2), 0, 0, CF_UNICODETEXT, 0); if (async) { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, 30000, NULL); + CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { ddeCookie = DdeCreateStringHandle(ddeInstance, TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, - CF_TEXT, XTYP_REQUEST, 30000, NULL); + CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); } } Tcl_DecrRefCount(objPtr); @@ -1692,10 +1711,11 @@ goto cleanup; } if (async == 0) { Tcl_Obj *resultPtr; + Tcl_UniChar *ddeDataString; /* * The return handle has a two or four element list in it. The * first element is the return code (TCL_OK, TCL_ERROR, etc.). * The second is the result of the script. If the return code @@ -1704,14 +1724,15 @@ * variable "errorInfo". */ resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); - Tcl_SetObjLength(resultPtr, (length + 1) * sizeof(TCHAR) - 1); - string = Tcl_GetString(resultPtr); - DdeGetData(ddeData, (BYTE *) string, (DWORD) length, 0); - Tcl_SetObjLength(resultPtr, (int) strlen(string)); + ddeDataString = ckalloc(length); + DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); + length = (length >> 1) - 1; + resultPtr = Tcl_NewUnicodeObj(ddeDataString, length); + ckfree(ddeDataString); if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); goto invalidServerResponse; }