From a31a6d94b9e9430c76fdc460fae32a9f1290d733 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 May 2012 07:50:59 +0000 Subject: proposal from jmphilippe --- win/tclWinDde.c | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 1fa922b..aa51689 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -550,7 +550,7 @@ DdeServerProc ( } if (convPtr != NULL) { - BYTE *returnString; + char *returnString; len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINANSI); @@ -561,19 +561,25 @@ DdeServerProc ( (DWORD) len + 1, CP_WINANSI); if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) { returnString = - (BYTE *)Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); + Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); + Tcl_DStringInit (&dString); + returnString = + Tcl_UtfToExternalDString (NULL, returnString, -1, &dString); ddeReturn = DdeCreateDataHandle(ddeInstance, - returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT, + (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT, 0); } else { Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex( convPtr->riPtr->interp, utilString, NULL, TCL_GLOBAL_ONLY); if (variableObjPtr != NULL) { - returnString = (BYTE *)Tcl_GetStringFromObj(variableObjPtr, + returnString = Tcl_GetStringFromObj(variableObjPtr, &len); + Tcl_DStringInit (&dString); + returnString = + Tcl_UtfToExternalDString (NULL, returnString, -1, &dString); ddeReturn = DdeCreateDataHandle(ddeInstance, - returnString, (DWORD) len+1, 0, ddeItem, + (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT, 0); } else { ddeReturn = NULL; -- cgit v0.12 From 3d51560e948b0600d4f3990406bca9167099c16b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 May 2012 08:47:19 +0000 Subject: [Bug 473946]: special characters not correctly sent --- ChangeLog | 4 ++++ win/tclWinDde.c | 57 +++++++++++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 51 insertions(+), 10 deletions(-) diff --git a/ChangeLog b/ChangeLog index 263d2c9..d7c07c2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2012-05-09 Jan Nijtmans + + * win/tclWinDde.c: [Bug 473946]: special characters not correctly sent + 2012-05-02 Jan Nijtmans * generic/configure.in: Better detection and implementation for cpuid diff --git a/win/tclWinDde.c b/win/tclWinDde.c index aa51689..8dc8af4 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -100,6 +100,27 @@ int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */ Tcl_Obj *CONST objv[]); /* The arguments */ EXTERN int Dde_Init(Tcl_Interp *interp); + +/* + * The following structures allow us to select between the Unicode and ASCII + * interfaces at run time based on whether Unicode APIs are available. The + * Unicode APIs are preferable because they will handle characters outside + * of the current code page. + */ + +typedef struct DdeWinProcs { + int uFmt; +} DdeWinProcs; + +static DdeWinProcs *ddeWinProcs; + +static DdeWinProcs asciiProcs = { + CF_TEXT +}; + +static DdeWinProcs unicodeProcs = { + CF_UNICODETEXT +}; /* *---------------------------------------------------------------------- @@ -124,6 +145,16 @@ Dde_Init( if (!Tcl_InitStubs(interp, "8.0", 0)) { return TCL_ERROR; } + /* + * Determine if the unicode interfaces are available and select the + * appropriate dde function table. + */ + + if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { + ddeWinProcs = &unicodeProcs; + } else { + ddeWinProcs = &asciiProcs; + } Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL); @@ -537,7 +568,7 @@ DdeServerProc ( * last execute. */ - if (uFmt != CF_TEXT) { + if ((uFmt != CF_TEXT) && (uFmt != ddeWinProcs->uFmt)) { return (HDDEDATA) FALSE; } @@ -562,11 +593,14 @@ DdeServerProc ( if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) { returnString = Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); - Tcl_DStringInit (&dString); - returnString = - Tcl_UtfToExternalDString (NULL, returnString, -1, &dString); + if (uFmt == CF_UNICODETEXT) { + Tcl_DStringFree(&dString); + returnString = + Tcl_WinUtfToTChar(returnString, len, &dString); + len = Tcl_DStringLength(&dString) + 1; + } ddeReturn = DdeCreateDataHandle(ddeInstance, - (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT, + (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); } else { Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex( @@ -575,12 +609,15 @@ DdeServerProc ( if (variableObjPtr != NULL) { returnString = Tcl_GetStringFromObj(variableObjPtr, &len); - Tcl_DStringInit (&dString); - returnString = - Tcl_UtfToExternalDString (NULL, returnString, -1, &dString); + if (uFmt == CF_UNICODETEXT) { + Tcl_DStringFree(&dString); + returnString = + Tcl_WinUtfToTChar(returnString, len, &dString); + len = Tcl_DStringLength(&dString) + 1; + } ddeReturn = DdeCreateDataHandle(ddeInstance, - (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, - CF_TEXT, 0); + (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, + uFmt, 0); } else { ddeReturn = NULL; } -- cgit v0.12 From 4d737ad3cb8cace53eb446a55b1674a967b6b164 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 May 2012 19:18:55 +0000 Subject: Increase version to 1.2.5 Now should work on Win95 as well Use Tcl_GetUnicodeFromObj in stead of Tcl_Win* functions, so we no longer have to detect whether we are on WinNT+ --- ChangeLog | 3 +- library/dde/pkgIndex.tcl | 4 +- win/tclWinDde.c | 265 ++++++++++++++++++++--------------------------- 3 files changed, 119 insertions(+), 153 deletions(-) diff --git a/ChangeLog b/ChangeLog index d7c07c2..98b77c9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,6 +1,7 @@ -2012-05-09 Jan Nijtmans +2012-05-?? Jan Nijtmans * win/tclWinDde.c: [Bug 473946]: special characters not correctly sent + * library/dde/pkgIndex.tcl Increase version to 1.2.5 2012-05-02 Jan Nijtmans diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index e414051..db67e98 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,7 +1,7 @@ if {![package vsatisfies [package provide Tcl] 8]} return if {[string compare [info sharedlibextension] .dll]} return if {[info exists ::tcl_platform(debug)]} { - package ifneeded dde 1.2.4 [list load [file join $dir tcldde12g.dll] dde] + package ifneeded dde 1.2.5 [list load [file join $dir tcldde12g.dll] dde] } else { - package ifneeded dde 1.2.4 [list load [file join $dir tcldde12.dll] dde] + package ifneeded dde 1.2.5 [list load [file join $dir tcldde12.dll] dde] } diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 8dc8af4..4e4d500 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1,4 +1,4 @@ -/* +/* * tclWinDde.c -- * * This file provides procedures that implement the "send" @@ -24,7 +24,7 @@ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLEXPORT -/* +/* * The following structure is used to keep track of the interpreters * registered by this process. */ @@ -68,9 +68,10 @@ static DWORD ddeInstance; /* The application instance handle given * to us by DdeInitialize. */ static int ddeIsServer = 0; -#define TCL_DDE_VERSION "1.2.4" -#define TCL_DDE_PACKAGE_NAME "dde" -#define TCL_DDE_SERVICE_NAME "TclEval" +#define TCL_DDE_VERSION "1.2.5" +#define TCL_DDE_PACKAGE_NAME "dde" +#define TCL_DDE_SERVICE_NAME "TclEval" +#define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT" TCL_DECLARE_MUTEX(ddeMutex) @@ -78,49 +79,27 @@ TCL_DECLARE_MUTEX(ddeMutex) * Forward declarations for procedures defined later in this file. */ -static void DdeExitProc _ANSI_ARGS_((ClientData clientData)); -static void DeleteProc _ANSI_ARGS_((ClientData clientData)); -static Tcl_Obj * ExecuteRemoteObject _ANSI_ARGS_(( - RegisteredInterp *riPtr, - Tcl_Obj *ddeObjectPtr)); -static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp, - char *name, HCONV *ddeConvPtr)); -static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType, +static void DdeExitProc(ClientData clientData); +static void DeleteProc(ClientData clientData); +static Tcl_Obj * ExecuteRemoteObject( + RegisteredInterp *riPtr, + Tcl_Obj *ddeObjectPtr); +static int MakeDdeConnection(Tcl_Interp *interp, + const char *name, HCONV *ddeConvPtr); +static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, - HSZ ddeItem, HDDEDATA hData, DWORD dwData1, - DWORD dwData2)); -static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp)); -static int DdeGetServicesList _ANSI_ARGS_(( + HSZ ddeItem, HDDEDATA hData, DWORD dwData1, + DWORD dwData2); +static void SetDdeError(Tcl_Interp *interp); +static int DdeGetServicesList( Tcl_Interp *interp, - char *serviceName, - char *topicName)); -int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */ - Tcl_Interp *interp, /* The interp we are sending from */ - int objc, /* Number of arguments */ - Tcl_Obj *CONST objv[]); /* The arguments */ - -EXTERN int Dde_Init(Tcl_Interp *interp); - -/* - * The following structures allow us to select between the Unicode and ASCII - * interfaces at run time based on whether Unicode APIs are available. The - * Unicode APIs are preferable because they will handle characters outside - * of the current code page. - */ - -typedef struct DdeWinProcs { - int uFmt; -} DdeWinProcs; + const char *serviceName, + const char *topicName); +static int DdeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); -static DdeWinProcs *ddeWinProcs; - -static DdeWinProcs asciiProcs = { - CF_TEXT -}; - -static DdeWinProcs unicodeProcs = { - CF_UNICODETEXT -}; +EXTERN int Dde_Init(Tcl_Interp *interp); /* *---------------------------------------------------------------------- @@ -142,24 +121,12 @@ int Dde_Init( Tcl_Interp *interp) { - if (!Tcl_InitStubs(interp, "8.0", 0)) { + if (!Tcl_InitStubs(interp, "8.1", 0)) { return TCL_ERROR; } - /* - * Determine if the unicode interfaces are available and select the - * appropriate dde function table. - */ - - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { - ddeWinProcs = &unicodeProcs; - } else { - ddeWinProcs = &asciiProcs; - } - - Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); - return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); } @@ -184,7 +151,7 @@ Initialize(void) { int nameFound = 0; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - + /* * See if the application is already registered; if so, remove its * current name from the registry. The deletion of the command @@ -206,7 +173,7 @@ Initialize(void) if (DdeInitialize(&ddeInstance, (PFNCALLBACK) DdeServerProc, CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS - | CBF_FAIL_POKES, 0) + | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) { ddeInstance = 0; } @@ -226,7 +193,7 @@ Initialize(void) } Tcl_MutexUnlock(&ddeMutex); } -} +} /* *-------------------------------------------------------------- @@ -256,7 +223,7 @@ Initialize(void) static char * DdeSetServerName( Tcl_Interp *interp, - char *name /* The name that will be used to + const char *name /* The name that will be used to * refer to the interpreter in later * "send" commands. Must be globally * unique. */ @@ -272,7 +239,7 @@ DdeSetServerName( * will take care of disposing of this entry. */ - for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL; + for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL; prevPtr = riPtr, riPtr = riPtr->nextPtr) { if (riPtr->interp == interp) { if (name != NULL) { @@ -302,7 +269,7 @@ DdeSetServerName( return ""; } - + /* * Pick a name to use for the application. Use "name" if it's not * already in use. Otherwise add a suffix such as " #2", trying @@ -323,7 +290,7 @@ DdeSetServerName( tsdPtr->interpListPtr = riPtr; strcpy(riPtr->name, name); - Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, + Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, (ClientData) riPtr, DeleteProc); if (Tcl_IsSafe(interp)) { Tcl_HideCommand(interp, "dde", "dde"); @@ -334,7 +301,7 @@ DdeSetServerName( * re-initialize with the new name */ Initialize(); - + return riPtr->name; } @@ -459,11 +426,11 @@ DdeServerProc ( * are performing. */ UINT uFmt, /* The format that data is sent or * received. */ - HCONV hConv, /* The conversation associated with the + HCONV hConv, /* The conversation associated with the * current transaction. */ - HSZ ddeTopic, /* A string handle. Transaction-type + HSZ ddeTopic, /* A string handle. Transaction-type * dependent. */ - HSZ ddeItem, /* A string handle. Transaction-type + HSZ ddeItem, /* A string handle. Transaction-type * dependent. */ HDDEDATA hData, /* DDE data. Transaction-type dependent. */ DWORD dwData1, /* Transaction-dependent data. */ @@ -508,7 +475,7 @@ DdeServerProc ( case XTYP_CONNECT_CONFIRM: /* - * Dde has decided that we can connect, so it gives us a + * Dde has decided that we can connect, so it gives us a * conversation handle. We need to keep track of it * so we know which execution result to return in an * XTYP_REQUEST. @@ -518,9 +485,9 @@ DdeServerProc ( Tcl_DStringInit(&dString); Tcl_DStringSetLength(&dString, len); utilString = Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, + DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, CP_WINANSI); - for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; + for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { if (stricmp(riPtr->name, utilString) == 0) { convPtr = (Conversation *) ckalloc(sizeof(Conversation)); @@ -543,7 +510,7 @@ DdeServerProc ( */ for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL; - convPtr != NULL; + convPtr != NULL; prevConvPtr = convPtr, convPtr = convPtr->nextPtr) { if (hConv == convPtr->hConv) { if (prevConvPtr == NULL) { @@ -568,7 +535,7 @@ DdeServerProc ( * last execute. */ - if ((uFmt != CF_TEXT) && (uFmt != ddeWinProcs->uFmt)) { + if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { return (HDDEDATA) FALSE; } @@ -588,36 +555,34 @@ DdeServerProc ( Tcl_DStringInit(&dString); Tcl_DStringSetLength(&dString, len); utilString = Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeItem, utilString, + DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINANSI); - if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) { - returnString = - Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); - if (uFmt == CF_UNICODETEXT) { - Tcl_DStringFree(&dString); + if (stricmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { + if (uFmt == CF_TEXT) { returnString = - Tcl_WinUtfToTChar(returnString, len, &dString); - len = Tcl_DStringLength(&dString) + 1; + Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); + } else { + returnString = (char *) + Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len); + len = 2 * len + 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, - (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, - 0); + (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); } else { Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex( - convPtr->riPtr->interp, utilString, NULL, + convPtr->riPtr->interp, utilString, NULL, TCL_GLOBAL_ONLY); if (variableObjPtr != NULL) { - returnString = Tcl_GetStringFromObj(variableObjPtr, - &len); - if (uFmt == CF_UNICODETEXT) { - Tcl_DStringFree(&dString); + if (uFmt == CF_TEXT) { returnString = - Tcl_WinUtfToTChar(returnString, len, &dString); - len = Tcl_DStringLength(&dString) + 1; + Tcl_GetStringFromObj(variableObjPtr, &len); + } else { + returnString = (char *) + Tcl_GetUnicodeFromObj(variableObjPtr, &len); + len = 2 * len + 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, - (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, - uFmt, 0); + (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); } else { ddeReturn = NULL; } @@ -657,7 +622,7 @@ DdeServerProc ( Tcl_DecrRefCount(convPtr->returnPackagePtr); } convPtr->returnPackagePtr = NULL; - returnPackagePtr = + returnPackagePtr = ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr); Tcl_IncrRefCount(returnPackagePtr); for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) @@ -679,7 +644,7 @@ DdeServerProc ( return (HDDEDATA) DDE_FACK; } } - + case XTYP_WILDCONNECT: { /* @@ -703,10 +668,10 @@ DdeServerProc ( (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0); returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen); len = dlen; - for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; + for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; i++, riPtr = riPtr->nextPtr) { returnPtr[i].hszSvc = DdeCreateStringHandle( - ddeInstance, "TclEval", CP_WINANSI); + ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINANSI); returnPtr[i].hszTopic = DdeCreateStringHandle( ddeInstance, riPtr->name, CP_WINANSI); } @@ -755,7 +720,7 @@ DdeExitProc( * * Results: * A standard Tcl result. - * + * * * Side effects: * Passes back a conversation through ddeConvPtr @@ -766,13 +731,13 @@ DdeExitProc( static int MakeDdeConnection( Tcl_Interp *interp, /* Used to report errors. */ - char *name, /* The connection to use. */ + const char *name, /* The connection to use. */ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; HCONV ddeConv; - - ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0); + + ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0); ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0); ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); @@ -818,7 +783,7 @@ typedef struct ddeEnumServices { HWND hwnd; } ddeEnumServices; -LRESULT CALLBACK +static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); static LRESULT DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam); @@ -845,7 +810,7 @@ DdeCreateClient(ddeEnumServices *es) return TCL_OK; } -LRESULT CALLBACK +static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam) { LRESULT lr = 0L; @@ -926,7 +891,7 @@ DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam) } static int -DdeGetServicesList(Tcl_Interp *interp, char *serviceName, char *topicName) +DdeGetServicesList(Tcl_Interp *interp, const char *serviceName, const char *topicName) { ddeEnumServices es; es.interp = interp; @@ -935,11 +900,11 @@ DdeGetServicesList(Tcl_Interp *interp, char *serviceName, char *topicName) ? (ATOM)0 : GlobalAddAtom(serviceName); es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtom(topicName); - + Tcl_ResetResult(interp); /* our list is to be appended to result. */ DdeCreateClient(&es); EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es); - + if (IsWindow(es.hwnd)) DestroyWindow(es.hwnd); if (es.service != (ATOM)0) @@ -959,7 +924,7 @@ DdeGetServicesList(Tcl_Interp *interp, char *serviceName, char *topicName) * * Results: * None. - * + * * * Side effects: * The interp's result object is changed. @@ -988,7 +953,7 @@ SetDdeError( break; case DMLERR_NOTPROCESSED: - Tcl_SetStringObj(resultPtr, + Tcl_SetStringObj(resultPtr, "remote server cannot handle this command", -1); break; @@ -1000,7 +965,7 @@ SetDdeError( /* *-------------------------------------------------------------- * - * Tcl_DdeObjCmd -- + * DdeObjCmd -- * * This procedure is invoked to process the "dde" Tcl command. * See the user documentation for details on what it does. @@ -1014,12 +979,12 @@ SetDdeError( *-------------------------------------------------------------- */ -int -Tcl_DdeObjCmd( +static int +DdeObjCmd( ClientData clientData, /* Used only for deletion */ Tcl_Interp *interp, /* The interp we are sending from */ int objc, /* Number of arguments */ - Tcl_Obj *CONST *objv) /* The arguments */ + Tcl_Obj *const *objv) /* The arguments */ { enum { DDE_SERVERNAME, @@ -1030,11 +995,11 @@ Tcl_DdeObjCmd( DDE_EVAL }; - static CONST char *ddeCommands[] = {"servername", "execute", "poke", - "request", "services", "eval", + static const char *ddeCommands[] = {"servername", "execute", "poke", + "request", "services", "eval", (char *) NULL}; - static CONST char *ddeOptions[] = {"-async", (char *) NULL}; - static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL}; + static const char *ddeOptions[] = {"-async", (char *) NULL}; + static const char *ddeReqOptions[] = {"-binary", (char *) NULL}; int index, argIndex; int async = 0, binary = 0; int result = TCL_OK; @@ -1045,7 +1010,7 @@ Tcl_DdeObjCmd( HDDEDATA ddeItemData = NULL; HCONV hConv = NULL; HSZ ddeCookie = 0; - char *serviceName, *topicName = NULL, *itemString; + const char *serviceName, *topicName = NULL, *itemString; char *string; int firstArg = 0, length, dataLength; DWORD ddeResult; @@ -1058,9 +1023,9 @@ Tcl_DdeObjCmd( /* * Initialize DDE server/client */ - + if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "?-async? serviceName topicName value"); return TCL_ERROR; } @@ -1080,7 +1045,7 @@ Tcl_DdeObjCmd( break; case DDE_EXECUTE: if ((objc < 5) || (objc > 6)) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "execute ?-async? serviceName topicName value"); return TCL_ERROR; } @@ -1113,7 +1078,7 @@ Tcl_DdeObjCmd( break; case DDE_REQUEST: if ((objc < 5) || (objc > 6)) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "request ?-binary? serviceName topicName value"); return TCL_ERROR; } @@ -1146,7 +1111,7 @@ Tcl_DdeObjCmd( break; case DDE_EVAL: if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "eval ?-async? serviceName args"); return TCL_ERROR; } @@ -1191,7 +1156,7 @@ Tcl_DdeObjCmd( if (length == 0) { topicName = NULL; } else { - ddeTopic = DdeCreateStringHandle(ddeInstance, + ddeTopic = DdeCreateStringHandle(ddeInstance, topicName, CP_WINANSI); } } @@ -1230,9 +1195,9 @@ Tcl_DdeObjCmd( (DWORD) dataLength+1, 0, 0, CF_TEXT, 0); if (ddeData != NULL) { if (async) { - DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, + DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); - DdeAbandonTransaction(ddeInstance, hConv, + DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, @@ -1259,13 +1224,13 @@ Tcl_DdeObjCmd( hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); - + if (hConv == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { Tcl_Obj *returnObjPtr; - ddeItem = DdeCreateStringHandle(ddeInstance, + ddeItem = DdeCreateStringHandle(ddeInstance, itemString, CP_WINANSI); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, @@ -1304,7 +1269,7 @@ Tcl_DdeObjCmd( goto errorNoResult; } dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 3], &length); - + hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); @@ -1348,12 +1313,12 @@ Tcl_DdeObjCmd( * See if the target interpreter is local. If so, execute * the command directly without going through the DDE server. * Don't exchange objects between interps. The target interp could - * compile an object, producing a bytecode structure that refers to - * other objects owned by the target interp. If the target interp - * is then deleted, the bytecode structure would be referring to + * compile an object, producing a bytecode structure that refers to + * other objects owned by the target interp. If the target interp + * is then deleted, the bytecode structure would be referring to * deallocated objects. */ - + for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { if (stricmp(serviceName, riPtr->name) == 0) { @@ -1366,11 +1331,11 @@ Tcl_DdeObjCmd( * This command is to a local interp. No need to go through * the server. */ - + Tcl_Preserve((ClientData) riPtr); sendInterp = riPtr->interp; Tcl_Preserve((ClientData) sendInterp); - + /* * Don't exchange objects between interps. The target interp * would compile an object, producing a bytecode structure that @@ -1396,13 +1361,13 @@ Tcl_DdeObjCmd( * from the destination interpreter back to our * interpreter. */ - + Tcl_ResetResult(interp); - objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, + objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); string = Tcl_GetStringFromObj(objPtr, &length); Tcl_AddObjErrorInfo(interp, string, length); - + objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL, TCL_GLOBAL_ONLY); Tcl_SetObjErrorCode(interp, objPtr); @@ -1416,16 +1381,16 @@ Tcl_DdeObjCmd( * This is a non-local request. Send the script to the server * and poll it for a result. */ - + if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { goto error; } - + objPtr = Tcl_ConcatObj(objc, objv); string = Tcl_GetStringFromObj(objPtr, &length); ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0); - + if (async) { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, @@ -1436,24 +1401,24 @@ Tcl_DdeObjCmd( 0xFFFFFFFF, hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { - - ddeCookie = DdeCreateStringHandle(ddeInstance, - "$TCLEVAL$EXECUTE$RESULT", CP_WINANSI); + + ddeCookie = DdeCreateStringHandle(ddeInstance, + TCL_DDE_EXECUTE_RESULT, CP_WINANSI); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, CF_TEXT, XTYP_REQUEST, 30000, NULL); } } Tcl_DecrRefCount(objPtr); - + if (ddeData == 0) { SetDdeError(interp); goto errorNoResult; } - + if (async == 0) { Tcl_Obj *resultPtr; - + /* * The return handle has a two or four element list in * it. The first element is the return code (TCL_OK, @@ -1462,14 +1427,14 @@ Tcl_DdeObjCmd( * element is the value of the variable "errorCode", and * the fourth is the value of the variable "errorInfo". */ - + resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); Tcl_SetObjLength(resultPtr, length); string = Tcl_GetString(resultPtr); DdeGetData(ddeData, (BYTE *) string, (DWORD) length, 0); Tcl_SetObjLength(resultPtr, (int) strlen(string)); - + if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); @@ -1490,7 +1455,7 @@ Tcl_DdeObjCmd( length = -1; string = Tcl_GetStringFromObj(objPtr, &length); Tcl_AddObjErrorInfo(interp, string, length); - + Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr); Tcl_SetObjErrorCode(interp, objPtr); } -- cgit v0.12 From 25566ea94ed5e5ecc53df06bd7e0f8f1349f001c Mon Sep 17 00:00:00 2001 From: ferrieux Date: Thu, 10 May 2012 21:43:30 +0000 Subject: [Bug 2812981]: Clean up bundled packages' build directory from within Tcl's ./configure, to avoid stale configuration. --- ChangeLog | 6 ++++++ unix/configure | 5 +++++ unix/configure.in | 5 +++++ win/configure | 5 +++++ win/configure.in | 5 +++++ 5 files changed, 26 insertions(+) diff --git a/ChangeLog b/ChangeLog index 6b02b23..bd13cb1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2012-05-10 Alexandre Ferrieux + + * {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 * generic/tclIORChan.c [Bug 3522560]: Fixed the crash, enabled the diff --git a/unix/configure b/unix/configure index 8f25c08..1151497 100755 --- a/unix/configure +++ b/unix/configure @@ -1353,6 +1353,11 @@ if test -r "$cache_file" -a -f "$cache_file"; then fi #------------------------------------------------------------------------ +# Empty slate for bundled packages, to avoid stale configuration +#------------------------------------------------------------------------ +rm -Rf pkgs + +#------------------------------------------------------------------------ # Handle the --prefix=... option #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 066a84f..4fc93dd 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -43,6 +43,11 @@ if test -r "$cache_file" -a -f "$cache_file"; then fi #------------------------------------------------------------------------ +# Empty slate for bundled packages, to avoid stale configuration +#------------------------------------------------------------------------ +rm -Rf pkgs + +#------------------------------------------------------------------------ # Handle the --prefix=... option #------------------------------------------------------------------------ diff --git a/win/configure b/win/configure index f3bd0d9..6673ecb 100755 --- a/win/configure +++ b/win/configure @@ -1329,6 +1329,11 @@ REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION PKG_CFG_ARGS=$@ #------------------------------------------------------------------------ +# Empty slate for bundled packages, to avoid stale configuration +#------------------------------------------------------------------------ +rm -Rf pkgs + +#------------------------------------------------------------------------ # Handle the --prefix=... option #------------------------------------------------------------------------ diff --git a/win/configure.in b/win/configure.in index 0ed8f89..1bab810 100644 --- a/win/configure.in +++ b/win/configure.in @@ -32,6 +32,11 @@ REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION PKG_CFG_ARGS=$@ #------------------------------------------------------------------------ +# Empty slate for bundled packages, to avoid stale configuration +#------------------------------------------------------------------------ +rm -Rf pkgs + +#------------------------------------------------------------------------ # Handle the --prefix=... option #------------------------------------------------------------------------ -- cgit v0.12 From 8084e168af0746710f165ebb4a157b45dc3b3756 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 May 2012 21:57:51 +0000 Subject: first shot at internationalization of dde --- win/tclWinDde.c | 101 +++++++++++++++++++++++++++++--------------------------- 1 file changed, 53 insertions(+), 48 deletions(-) diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 629af10..48bb53d 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -19,6 +19,11 @@ #include #include +#ifndef UNICODE +# undef CP_WINUNICODE +# define CP_WINUNICODE CP_WINANSI +#endif + /* * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init * declaration is in the source file itself, which is only accessed when we @@ -38,7 +43,7 @@ typedef struct RegisteredInterp { struct RegisteredInterp *nextPtr; /* The next interp this application knows * about. */ - char *name; /* Interpreter's name (malloc-ed). */ + TCHAR *name; /* Interpreter's name (malloc-ed). */ Tcl_Obj *handlerPtr; /* The server handler command */ Tcl_Interp *interp; /* The interpreter attached to this name. */ } RegisteredInterp; @@ -85,8 +90,8 @@ static int ddeIsServer = 0; #define TCL_DDE_VERSION "1.3.3" #define TCL_DDE_PACKAGE_NAME "dde" -#define TCL_DDE_SERVICE_NAME "TclEval" -#define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT" +#define TCL_DDE_SERVICE_NAME TEXT("TclEval") +#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") TCL_DECLARE_MUTEX(ddeMutex) @@ -101,7 +106,7 @@ static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); static void DdeExitProc(ClientData clientData); static int DdeGetServicesList(Tcl_Interp *interp, - const char *serviceName, const char *topicName); + const TCHAR *serviceName, const TCHAR *topicName); static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2); @@ -111,7 +116,7 @@ static void DeleteProc(ClientData clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, - const char *name, HCONV *ddeConvPtr); + const TCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); static int DdeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -264,10 +269,10 @@ Initialize(void) *---------------------------------------------------------------------- */ -static const char * +static const TCHAR * DdeSetServerName( Tcl_Interp *interp, - const char *name, /* The name that will be used to refer to the + const TCHAR *name, /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ int exactName, /* Should we make a unique name? 0 = unique */ @@ -277,7 +282,7 @@ DdeSetServerName( int suffix, offset; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; - const char *actualName; + const TCHAR *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -315,15 +320,16 @@ DdeSetServerName( * current interp, but it doesn't have a name. */ - return ""; + return TEXT(""); } + Tcl_DStringInit(&dString); + /* * Get the list of currently registered Tcl interpreters by calling the * internal implementation of the 'dde services' command. */ - Tcl_DStringInit(&dString); actualName = name; if (!exactName) { @@ -370,7 +376,7 @@ DdeSetServerName( Tcl_Obj* namePtr; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); - if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) { + if (_tcscmp(actualName, Tcl_GetString(namePtr)) == 0) { suffix++; break; } @@ -386,14 +392,14 @@ DdeSetServerName( riPtr = ckalloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = ckalloc(strlen(actualName) + 1); + riPtr->name = ckalloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); riPtr->nextPtr = tsdPtr->interpListPtr; riPtr->handlerPtr = handlerPtr; if (riPtr->handlerPtr != NULL) { Tcl_IncrRefCount(riPtr->handlerPtr); } tsdPtr->interpListPtr = riPtr; - strcpy(riPtr->name, actualName); + _tcscpy(riPtr->name, actualName); if (Tcl_IsSafe(interp)) { Tcl_ExposeCommand(interp, "dde", "dde"); @@ -609,7 +615,7 @@ DdeServerProc( Tcl_DString dString; int len; DWORD dlen; - char *utilString; + TCHAR *utilString; Tcl_Obj *ddeObjectPtr; HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; @@ -625,14 +631,14 @@ DdeServerProc( len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, - CP_WINANSI); + CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (stricmp(utilString, riPtr->name) == 0) { + if (_tcsicmp(utilString, riPtr->name) == 0) { Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; } @@ -650,13 +656,13 @@ DdeServerProc( len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, - CP_WINANSI); + CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (stricmp(riPtr->name, utilString) == 0) { + if (_tcsicmp(riPtr->name, utilString) == 0) { convPtr = ckalloc(sizeof(Conversation)); convPtr->nextPtr = tsdPtr->currentConversations; convPtr->returnPackagePtr = NULL; @@ -715,13 +721,13 @@ DdeServerProc( if (convPtr != NULL) { char *returnString; - len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINANSI); + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, - CP_WINANSI); - if (stricmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { + CP_WINUNICODE); + if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { if (uFmt == CF_TEXT) { returnString = Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); @@ -779,7 +785,7 @@ DdeServerProc( return (HDDEDATA) DDE_FNOTPROCESSED; } - utilString = (char *) DdeAccessData(hData, &dlen); + utilString = (TCHAR *) DdeAccessData(hData, &dlen); len = dlen; ddeObjectPtr = Tcl_NewStringObj(utilString, -1); Tcl_IncrRefCount(ddeObjectPtr); @@ -833,9 +839,9 @@ DdeServerProc( for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; i++, riPtr = riPtr->nextPtr) { returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance, - TCL_DDE_SERVICE_NAME, CP_WINANSI); + TCL_DDE_SERVICE_NAME, CP_WINUNICODE); returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance, - riPtr->name, CP_WINANSI); + riPtr->name, CP_WINUNICODE); } returnPtr[i].hszSvc = NULL; returnPtr[i].hszTopic = NULL; @@ -893,7 +899,7 @@ DdeExitProc( static int MakeDdeConnection( Tcl_Interp *interp, /* Used to report errors. */ - const char *name, /* The connection to use. */ + const TCHAR *name, /* The connection to use. */ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; @@ -944,8 +950,8 @@ DdeCreateClient( struct DdeEnumServices *es) { WNDCLASSEX wc; - static const char *szDdeClientClassName = "TclEval client class"; - static const char *szDdeClientWindowName = "TclEval client window"; + static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); + static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window"); memset(&wc, 0, sizeof(wc)); wc.cbSize = sizeof(wc); @@ -970,7 +976,6 @@ DdeClientWindowProc( WPARAM wParam, LPARAM lParam) /* (Potentially) our local handle */ { - switch (uMsg) { case WM_CREATE: { LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; @@ -986,7 +991,6 @@ DdeClientWindowProc( } case WM_DDE_ACK: return DdeServicesOnAck(hwnd, wParam, lParam); - break; default: return DefWindowProc(hwnd, uMsg, wParam, lParam); } @@ -1002,7 +1006,7 @@ DdeServicesOnAck( ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); struct DdeEnumServices *es; - char sz[255]; + TCHAR sz[255]; #ifdef _WIN64 es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); @@ -1065,8 +1069,8 @@ DdeEnumWindowsCallback( static int DdeGetServicesList( Tcl_Interp *interp, - const char *serviceName, - const char *topicName) + const TCHAR *serviceName, + const TCHAR *topicName) { struct DdeEnumServices es; @@ -1189,7 +1193,8 @@ DdeObjCmd( HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; - const char *serviceName = NULL, *topicName = NULL, *string; + const TCHAR *serviceName = NULL, *topicName = NULL; + const char *string; DWORD ddeResult; Tcl_Obj *objPtr, *handlerPtr = NULL; @@ -1339,7 +1344,7 @@ DdeObjCmd( serviceName = NULL; } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName, - CP_WINANSI); + CP_WINUNICODE); } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { @@ -1348,7 +1353,7 @@ DdeObjCmd( topicName = NULL; } else { ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName, - CP_WINANSI); + CP_WINUNICODE); } } @@ -1428,7 +1433,7 @@ DdeObjCmd( } else { Tcl_Obj *returnObjPtr; ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, - CP_WINANSI); + CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, CF_TEXT, XTYP_REQUEST, 5000, NULL); @@ -1481,7 +1486,7 @@ DdeObjCmd( result = TCL_ERROR; } else { ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, - CP_WINANSI); + CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(dataString, (DWORD) length+1, hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL); @@ -1527,7 +1532,7 @@ DdeObjCmd( for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (stricmp(serviceName, riPtr->name) == 0) { + if (_tcsicmp(serviceName, riPtr->name) == 0) { break; } } @@ -1620,8 +1625,7 @@ DdeObjCmd( if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { invalidServerResponse: Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid data returned from server", - -1)); + Tcl_NewStringObj("invalid data returned from server", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL); result = TCL_ERROR; goto cleanup; @@ -1643,7 +1647,7 @@ DdeObjCmd( CF_TEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { ddeCookie = DdeCreateStringHandle(ddeInstance, - TCL_DDE_EXECUTE_RESULT, CP_WINANSI); + TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, CF_TEXT, XTYP_REQUEST, 30000, NULL); } @@ -1654,6 +1658,7 @@ DdeObjCmd( if (ddeData == 0) { SetDdeError(interp); result = TCL_ERROR; + goto cleanup; } if (async == 0) { @@ -1670,7 +1675,7 @@ DdeObjCmd( resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); - Tcl_SetObjLength(resultPtr, length); + 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)); -- cgit v0.12 From 515c4f1a4cc29e7f4dd2fb0ca65aaec0e0172cab Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 May 2012 14:46:56 +0000 Subject: Protect against receiving strings without ending \0, as external applications (or Tcl with TIP #106) could generate that. --- ChangeLog | 5 +++++ win/tclWinDde.c | 15 +++++++++++---- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6add097..1615237 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +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 diff --git a/win/tclWinDde.c b/win/tclWinDde.c index ebba2f3..3b8ca23 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -591,7 +591,10 @@ DdeServerProc( utilString = (char *) DdeAccessData(hData, &dlen); len = dlen; - ddeObjectPtr = Tcl_NewStringObj(utilString, -1); + if (len && !utilString[len-1]) { + len--; + } + ddeObjectPtr = Tcl_NewStringObj(utilString, len); Tcl_IncrRefCount(ddeObjectPtr); DdeUnaccessData(hData); if (convPtr->returnPackagePtr != NULL) { @@ -1200,13 +1203,17 @@ DdeObjCmd( result = TCL_ERROR; } else { DWORD tmp; - const BYTE *dataString = DdeAccessData(ddeData, &tmp); + const char *dataString = (const char *) DdeAccessData(ddeData, &tmp); if (binary) { - returnObjPtr = Tcl_NewByteArrayObj(dataString, + returnObjPtr = Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); } else { - returnObjPtr = Tcl_NewStringObj((char *)dataString, -1); + if (tmp && !dataString[tmp-1]) { + --tmp; + } + returnObjPtr = Tcl_NewStringObj(dataString, + (int) tmp); } DdeUnaccessData(ddeData); DdeFreeDataHandle(ddeData); -- cgit v0.12 From 7ac6053161fe49bc32f962b38e67f94f172ce709 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 May 2012 22:26:54 +0000 Subject: revert part of [9922ac54e8]: remove Tcl_MacOSXOpenBundleResources and Tcl_MacOSXOpenVersionedBundleResources from the UNIX stub table, instead let cygwin make use of the win32 stub table --- generic/tcl.decls | 13 ++++--- generic/tclPlatDecls.h | 60 +++++++++++++++---------------- generic/tclStubInit.c | 14 +++----- tools/genStubs.tcl | 95 ++++---------------------------------------------- 4 files changed, 49 insertions(+), 133 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 41e3d1d..db9950c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1493,7 +1493,6 @@ declare 420 { declare 421 { Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const char *key) } - declare 422 { Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, const char *key, int *newPtr) @@ -1798,12 +1797,16 @@ declare 573 { ############################################################################## -# Define the platform specific public Tcl interface. These functions are -# only available on the designated platform. +# Define the platform specific public Tcl interface. These functions are only +# available on the designated platform. interface tclPlat ################################ +# Unix specific functions +# (none) + +################################ # Windows specific functions # Added in Tcl 8.1 @@ -1867,12 +1870,12 @@ declare 8 mac { ################################ # Mac OS X specific functions -declare 0 unix { +declare 0 macosx { int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath) } -declare 1 unix { +declare 1 macosx { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath) diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 02191ca..b288296 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -29,20 +29,7 @@ * Exported function declarations: */ -#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ -/* 0 */ -EXTERN int Tcl_MacOSXOpenBundleResources _ANSI_ARGS_(( - Tcl_Interp *interp, CONST char *bundleName, - int hasResourceFile, int maxPathLen, - char *libraryPath)); -/* 1 */ -EXTERN int Tcl_MacOSXOpenVersionedBundleResources _ANSI_ARGS_(( - Tcl_Interp *interp, CONST char *bundleName, - CONST char *bundleVersion, - int hasResourceFile, int maxPathLen, - char *libraryPath)); -#endif /* UNIX */ -#ifdef __WIN32__ +#if defined(__WIN32__) || defined(__CYGWIN__) /* 0 */ EXTERN TCHAR * Tcl_WinUtfToTChar _ANSI_ARGS_((CONST char *str, int len, Tcl_DString *dsPtr)); @@ -81,16 +68,25 @@ EXTERN int strncasecmp _ANSI_ARGS_((CONST char *s1, EXTERN int strcasecmp _ANSI_ARGS_((CONST char *s1, CONST char *s2)); #endif /* MAC_TCL */ +#ifdef MAC_OSX_TCL +/* 0 */ +EXTERN int Tcl_MacOSXOpenBundleResources _ANSI_ARGS_(( + Tcl_Interp *interp, CONST char *bundleName, + int hasResourceFile, int maxPathLen, + char *libraryPath)); +/* 1 */ +EXTERN int Tcl_MacOSXOpenVersionedBundleResources _ANSI_ARGS_(( + Tcl_Interp *interp, CONST char *bundleName, + CONST char *bundleVersion, + int hasResourceFile, int maxPathLen, + char *libraryPath)); +#endif /* MAC_OSX_TCL */ typedef struct TclPlatStubs { int magic; struct TclPlatStubHooks *hooks; -#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ - int (*tcl_MacOSXOpenBundleResources) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath)); /* 0 */ - int (*tcl_MacOSXOpenVersionedBundleResources) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *bundleName, CONST char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath)); /* 1 */ -#endif /* UNIX */ -#ifdef __WIN32__ +#if defined(__WIN32__) || defined(__CYGWIN__) TCHAR * (*tcl_WinUtfToTChar) _ANSI_ARGS_((CONST char *str, int len, Tcl_DString *dsPtr)); /* 0 */ char * (*tcl_WinTCharToUtf) _ANSI_ARGS_((CONST TCHAR *str, int len, Tcl_DString *dsPtr)); /* 1 */ #endif /* __WIN32__ */ @@ -105,6 +101,10 @@ typedef struct TclPlatStubs { int (*strncasecmp) _ANSI_ARGS_((CONST char *s1, CONST char *s2, size_t n)); /* 7 */ int (*strcasecmp) _ANSI_ARGS_((CONST char *s1, CONST char *s2)); /* 8 */ #endif /* MAC_TCL */ +#ifdef MAC_OSX_TCL + int (*tcl_MacOSXOpenBundleResources) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath)); /* 0 */ + int (*tcl_MacOSXOpenVersionedBundleResources) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *bundleName, CONST char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath)); /* 1 */ +#endif /* MAC_OSX_TCL */ } TclPlatStubs; #ifdef __cplusplus @@ -121,17 +121,7 @@ extern TclPlatStubs *tclPlatStubsPtr; * Inline function declarations: */ -#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ -#ifndef Tcl_MacOSXOpenBundleResources -#define Tcl_MacOSXOpenBundleResources \ - (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ -#endif -#ifndef Tcl_MacOSXOpenVersionedBundleResources -#define Tcl_MacOSXOpenVersionedBundleResources \ - (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ -#endif -#endif /* UNIX */ -#ifdef __WIN32__ +#if defined(__WIN32__) || defined(__CYGWIN__) #ifndef Tcl_WinUtfToTChar #define Tcl_WinUtfToTChar \ (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ @@ -179,6 +169,16 @@ extern TclPlatStubs *tclPlatStubsPtr; (tclPlatStubsPtr->strcasecmp) /* 8 */ #endif #endif /* MAC_TCL */ +#ifdef MAC_OSX_TCL +#ifndef Tcl_MacOSXOpenBundleResources +#define Tcl_MacOSXOpenBundleResources \ + (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ +#endif +#ifndef Tcl_MacOSXOpenVersionedBundleResources +#define Tcl_MacOSXOpenVersionedBundleResources \ + (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ +#endif +#endif /* MAC_OSX_TCL */ #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1ed349c..87c5039 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -187,10 +187,6 @@ Tcl_WinTCharToUtf( string, len, dsPtr); } -#define Tcl_MacOSXOpenBundleResources (int (*) _ANSI_ARGS_(( \ - Tcl_Interp *, CONST char *, int, int, char *))) Tcl_WinUtfToTChar -#define Tcl_MacOSXOpenVersionedBundleResources (int (*) _ANSI_ARGS_(( \ - Tcl_Interp *, CONST char *, CONST char *, int, int, char *))) Tcl_WinTCharToUtf #define TclMacOSXGetFileAttribute (int (*) _ANSI_ARGS_((Tcl_Interp *, \ int, Tcl_Obj *, Tcl_Obj **))) TclpCreateProcess #define TclMacOSXMatchType (int (*) _ANSI_ARGS_((Tcl_Interp *, CONST char *, \ @@ -560,11 +556,7 @@ TclIntPlatStubs tclIntPlatStubs = { TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, NULL, -#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ - Tcl_MacOSXOpenBundleResources, /* 0 */ - Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ -#endif /* UNIX */ -#ifdef __WIN32__ +#if defined(__WIN32__) || defined(__CYGWIN__) Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ #endif /* __WIN32__ */ @@ -579,6 +571,10 @@ TclPlatStubs tclPlatStubs = { strncasecmp, /* 7 */ strcasecmp, /* 8 */ #endif /* MAC_TCL */ +#ifdef MAC_OSX_TCL + Tcl_MacOSXOpenBundleResources, /* 0 */ + Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ +#endif /* MAC_OSX_TCL */ }; static TclStubHooks tclStubHooks = { diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index c2b0b27..009db07 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -242,7 +242,7 @@ proc genStubs::addPlatformGuard {plat text} { return "#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */\n${text}#endif /* X11 */\n" } } - return "$text" + return $text } # genStubs::emitSlots -- @@ -451,71 +451,6 @@ proc genStubs::makeMacro {name decl index} { return $text } -# genStubs::makeStub -- -# -# Emits a stub function definition. -# -# Arguments: -# name The interface name. -# decl The function declaration. -# index The slot index for this function. -# -# Results: -# Returns the formatted stub function definition. - -proc genStubs::makeStub {name decl index} { - lassign $decl rtype fname args - - set lfname [string tolower [string index $fname 0]] - append lfname [string range $fname 1 end] - - append text "/* Slot $index */\n" $rtype "\n" $fname - - set arg1 [lindex $args 0] - - if {![string compare $arg1 "TCL_VARARGS"]} { - lassign [lindex $args 1] type argName - append text " TCL_VARARGS_DEF($type,$argName)\n\{\n" - append text " " $type " var;\n va_list argList;\n" - if {[string compare $rtype "void"]} { - append text " " $rtype " resultValue;\n" - } - append text "\n var = (" $type ") TCL_VARARGS_START(" \ - $type "," $argName ",argList);\n\n " - if {[string compare $rtype "void"]} { - append text "resultValue = " - } - append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n" - append text " va_end(argList);\n" - if {[string compare $rtype "void"]} { - append text "return resultValue;\n" - } - append text "\}\n\n" - return $text - } - - if {![string compare $arg1 "void"]} { - set argList "()" - set argDecls "" - } else { - set argList "" - set sep "(" - foreach arg $args { - append argList $sep [lindex $arg 1] - append argDecls " " [lindex $arg 0] " " \ - [lindex $arg 1] [lindex $arg 2] ";\n" - set sep ", " - } - append argList ")" - } - append text $argList "\n" $argDecls "{\n " - if {[string compare $rtype "void"]} { - append text "return " - } - append text "(" $name "StubsPtr->" $lfname ")" $argList ";\n}\n\n" - return $text -} - # genStubs::makeSlot -- # # Generate the stub table entry for a function. @@ -538,8 +473,11 @@ proc genStubs::makeSlot {name decl index} { if {($rtype != "void") && ($rtype != "pascal void")} { regsub -all void $rtype VOID rtype } - append text $rtype " (*" $lfname ") _ANSI_ARGS_(" - + if {[string range $rtype end-8 end] == "__stdcall"} { + append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") _ANSI_ARGS_(" + } else { + append text $rtype " (*" $lfname ") _ANSI_ARGS_(" + } regsub -all void $args VOID args set arg1 [lindex $args 0] switch -exact $arg1 { @@ -823,27 +761,6 @@ proc genStubs::emitHeader {name} { return } -# genStubs::emitStubs -- -# -# This function emits the body of the Stubs.c file for -# the specified interface. -# -# Arguments: -# name The name of the interface being emitted. -# -# Results: -# None. - -proc genStubs::emitStubs {name} { - variable outDir - - append text "\n/*\n * Exported stub functions:\n */\n\n" - forAllStubs $name makeStub 0 text - - rewriteFile [file join $outDir ${name}Stubs.c] $text - return -} - # genStubs::emitInit -- # # Generate the table initializers for an interface. -- cgit v0.12 From 6155ef4e5cc74b11bfb0eba745e4e9c9c5e5f6be Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 16 May 2012 14:11:45 +0000 Subject: [Bug 3445787]: Improve the compatibility of safe interpreters' version of 'file' with that of unsafe interpreters. --- ChangeLog | 10 +++++++- generic/tclCmdAH.c | 42 +++++++++++++++++++++++++++++-- library/safe.tcl | 73 ++++++++++++++++++++++-------------------------------- tests/safe.test | 4 +-- 4 files changed, 80 insertions(+), 49 deletions(-) diff --git a/ChangeLog b/ChangeLog index b4a6a8d..72af5c4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +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, @@ -21,7 +29,7 @@ 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 diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 70aef8d..4292224 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -61,6 +61,7 @@ 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; @@ -581,7 +582,7 @@ Tcl_EncodingObjCmd( 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); @@ -628,10 +629,12 @@ EncodingDirsObjCmd( 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; @@ -1057,6 +1060,8 @@ TclMakeFileCommandSafe( unsafeInfo[i].cmdName, Tcl_GetString(Tcl_GetObjResult(interp))); } + Tcl_CreateObjCommand(interp, oldName, BadFileSubcommand, + (ClientData) unsafeInfo[i].cmdName, NULL); } } Tcl_DStringFree(&oldBuf); @@ -1078,6 +1083,39 @@ TclMakeFileCommandSafe( /* *---------------------------------------------------------------------- * + * 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 -- * * This function is invoked to process the "file atime" Tcl command. See diff --git a/library/safe.tcl b/library/safe.tcl index 95db3b2..b9be5a7 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -465,8 +465,18 @@ proc ::safe::InterpInit { # 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} { @@ -980,58 +990,33 @@ proc ::safe::DirInAccessPath {slave dir} { } } -# This procedure enables access from a safe interpreter to only a subset -# of the subcommands of a command: +# This procedure is used to report an attempt to use an unsafe member of an +# ensemble command. -proc ::safe::Subset {slave command okpat args} { - set subcommand [lindex $args 0] - if {[regexp $okpat $subcommand]} { - return [$command {*}$args] - } +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" - } + # 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\"" } - 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] + } on error {msg options} { + Log $slave $msg + return -options $options $msg } - Log $slave $msg - return -code error -errorcode $code $msg + tailcall ::interp invokehidden $slave encoding $option {*}$args } # Various minor hiding of platform features. [Bug 2913625] diff --git a/tests/safe.test b/tests/safe.test index 2d7f476..827ea11 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -94,7 +94,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup { 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 { @@ -556,7 +556,7 @@ test safe-13.1 {safe file ensemble does not surprise code} -setup { 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 -- cgit v0.12 From 03716dfee8f0f0df26a8c56e6a2b3ceeb9319dbc Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 16 May 2012 23:16:14 +0000 Subject: [Bug 3525462]: Document what relational operators really do with string args. --- ChangeLog | 6 ++++++ doc/expr.n | 6 +++--- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index 1615237..fad0871 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2012-05-17 Donal K. Fellows + + * 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-13 Jan Nijtmans * win/tclWinDde.c: Protect against receiving strings without ending \0, diff --git a/doc/expr.n b/doc/expr.n index e529925..4c8903a 100644 --- a/doc/expr.n +++ b/doc/expr.n @@ -364,6 +364,7 @@ returns \fB4.0\fR, not \fB4\fR. 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, .VS 8.4 except in the case of the \fBeq\fR and \fBne\fR operators. .VE 8.4 @@ -374,11 +375,10 @@ a string using the C \fIsprintf\fR format specifier For example, the commands .CS \fBexpr {"0x03" > "2"}\fR -\fBexpr {"0y" < "0x12"}\fR +\fBexpr {"0y" > "0x12"}\fR .CE 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 isn't generally a good idea to use operators like \fB==\fR when you really want string comparison and the values of the -- cgit v0.12 From cd0d91b040445f935fa68474e55aa2504113cd94 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 17 May 2012 10:27:51 +0000 Subject: minor: ChangeLog formatting fixes --- ChangeLog | 100 +++++++++++++++++++++++++++++++++----------------------------- 1 file changed, 53 insertions(+), 47 deletions(-) diff --git a/ChangeLog b/ChangeLog index 36ecd23..8f3a0f0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -14,17 +14,18 @@ 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. + * 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. @@ -49,29 +50,30 @@ 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 @@ -114,10 +116,11 @@ 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: @@ -527,10 +530,10 @@ * 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 @@ -553,9 +556,9 @@ 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 @@ -579,7 +582,7 @@ 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: @@ -1367,7 +1370,8 @@ 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 @@ -2103,9 +2107,9 @@ * 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 @@ -2514,8 +2518,8 @@ * 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 @@ -2666,9 +2670,9 @@ [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 @@ -2773,7 +2777,8 @@ * 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 @@ -3494,8 +3499,8 @@ 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 @@ -5696,10 +5701,11 @@ 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 *) @@ -5825,10 +5831,10 @@ 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 -- cgit v0.12 From eb98b2c7785409192628ad59475e3581ca2b901b Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 17 May 2012 14:14:26 +0000 Subject: [Bug 2964715]: fixes to globbing in safe interpreters --- ChangeLog | 5 ++ library/safe.tcl | 47 +++++++++------ tests/safe.test | 178 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 212 insertions(+), 18 deletions(-) diff --git a/ChangeLog b/ChangeLog index c841b77..5850670 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,10 @@ 2012-05-17 Donal K. Fellows + * 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). diff --git a/library/safe.tcl b/library/safe.tcl index 8a99032..1a340a1 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -491,7 +491,8 @@ proc ::safe::InterpInit { # 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 } @@ -670,9 +671,9 @@ proc ::safe::AliasGlob {slave args} { } if {$::tcl_platform(platform) eq "windows"} { - set dirPartRE {^(.*)[\\/]} + set dirPartRE {^(.*)[\\/]([^\\/]*)$} } else { - set dirPartRE {^(.*)/} + set dirPartRE {^(.*)/([^/]*)$} } set dir {} @@ -725,11 +726,10 @@ proc ::safe::AliasGlob {slave args} { DirInAccessPath $slave $dir } msg]} { Log $slave $msg - if {!$got(-nocomplain)} { - return -code error "permission denied" - } else { + if {$got(-nocomplain)} { return } + return -code error "permission denied" } lappend cmd -directory $dir } @@ -741,19 +741,32 @@ proc ::safe::AliasGlob {slave args} { # Process remaining pattern arguments set firstPattern [llength $cmd] - while {$at < [llength $args]} { - set opt [lindex $args $at] - incr at - if {[regexp $dirPartRE $opt -> thedir] && [catch { + foreach opt [lrange $args $at end] { + if {![regexp $dirPartRE $opt -> thedir thefile]} { + set thedir . + } + if {$thedir eq "*"} { + set mapped 0 + foreach d [glob -directory [TranslatePath $slave $virtualdir] \ + -types d -tails *] { + catch { + DirInAccessPath $slave \ + [TranslatePath $slave [file join $virtualdir $d]] + if {$thefile eq "pkgIndex.tcl" || $thefile eq "*.tm"} { + lappend cmd [file join $d $thefile] + set mapped 1 + } + } + } + if {$mapped} continue + } + if {[catch { set thedir [file join $virtualdir $thedir] DirInAccessPath $slave [TranslatePath $slave $thedir] } msg]} { Log $slave $msg - if {$got(-nocomplain)} { - continue - } else { - return -code error "permission denied" - } + if {$got(-nocomplain)} continue + return -code error "permission denied" } lappend cmd $opt } @@ -770,7 +783,7 @@ proc ::safe::AliasGlob {slave args} { return -code error "script error" } - Log $slave "GLOB @ $msg" NOTICE + Log $slave "GLOB < $msg" NOTICE # Translate path back to what the slave should see. set res {} @@ -782,7 +795,7 @@ proc ::safe::AliasGlob {slave args} { lappend res $p } - Log $slave "GLOB @ $res" NOTICE + Log $slave "GLOB > $res" NOTICE return $res } diff --git a/tests/safe.test b/tests/safe.test index fbcb2a1..7b83cc6 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -30,7 +30,7 @@ set ::auto_path [info library] catch {safe::interpConfigure} proc equiv {x} {return $x} - + test safe-1.1 {safe::interpConfigure syntax} { list [catch {safe::interpConfigure} msg] $msg; } {1 {no value given for parameter "slave" (use -help for full usage) : @@ -515,6 +515,182 @@ test safe-12.6 {glob is restricted [Bug 2906841]} -setup { safe::interpDelete $i } -result {} +proc mkfile {filename} { + close [open $filename w] +} +#### 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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -body { + $i eval glob -directory $testdir2 *.tm +} -returnCodes error -cleanup { + safe::interpDelete $i + file delete -force $testdir +} -result {permission denied} +test safe-13.4 {another valid glob call [Bug 2964715]} -setup { + set i [safe::interpCreate] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -body { + ::safe::interpAddToAccessPath $i $testdir2 + $i eval \ + glob -directory $testdir [file join deletemetoo *.tm] +} -returnCodes error -cleanup { + safe::interpDelete $i + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -body { + ::safe::interpAddToAccessPath $i $testdir + $i eval \ + glob -nocomplain -directory $testdir [file join deletemetoo *.tm] +} -cleanup { + safe::interpDelete $i + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 pkgIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 notIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 notIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 notIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -body { + ::safe::interpAddToAccessPath $i $testdir + $i eval glob -directory $testdir -join -nocomplain * notIndex.tcl +} -cleanup { + safe::interpDelete $i + file delete -force $testdir +} -result {} +rename mkfile {} + +#### 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 +} -result [::tcl::tm::path list] + set ::auto_path $saveAutoPath # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 1e55ed351f4f2db6a9c633227fd691df7eb7b347 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 17 May 2012 15:01:46 +0000 Subject: [Bug 3527618]: Stabilize tests that use [info frame 0] --- tests/dict.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/dict.test b/tests/dict.test index 5277cf6..77bacf6 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1475,7 +1475,7 @@ 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}}}} { @@ -1487,14 +1487,14 @@ test dict-23.1 {dict compilation crash: Bug 3487626} { } } } - }} [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 { @@ -1518,7 +1518,7 @@ j } } } - }} [linenumber] + }} [linenumber]}} } 5 rename linenumber {} -- cgit v0.12 From 70e6283bef9733ca12935627fda82f732e5cabd9 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 17 May 2012 16:40:38 +0000 Subject: * 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. --- ChangeLog | 9 +++++++++ generic/tclCmdMZ.c | 8 ++++++-- tests/switch.test | 22 ++++++++++++++++------ 3 files changed, 31 insertions(+), 8 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5850670..6ea446c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,14 @@ 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 diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 531e2b1..0ad77aa 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3679,8 +3679,12 @@ Tcl_SwitchObjCmd( 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. diff --git a/tests/switch.test b/tests/switch.test index 5ee7216..f04f636 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -536,7 +536,7 @@ test switch-11.6 {-matchvar unwritable} { 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}} @@ -544,7 +544,7 @@ test switch-12.2 {regexp matching with -indexvar} { } 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" { @@ -560,22 +560,32 @@ 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 - @@ -597,7 +607,7 @@ test switch-13.6 {-indexvar -matchvar combinations} { 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 { -- cgit v0.12 From 6e977b903ee0e35f5b799abe1c8b3c902a5b5cef Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 17 May 2012 17:20:49 +0000 Subject: Cancel the timeout timers! If this isn't done, lingering timers from early tests can trigger false timeouts of later tests (since they are all using a common variable name). --- tests/zlib.test | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/zlib.test b/tests/zlib.test index 3aaca29..d8d710a 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -147,6 +147,7 @@ test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait total + after cancel {set total timeout} } finally { close $sin } @@ -226,6 +227,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup 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 { @@ -251,6 +253,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { 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 { @@ -284,6 +287,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { 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 { @@ -312,6 +316,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup { } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { @@ -339,6 +344,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup { } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { @@ -366,6 +372,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup { } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { @@ -396,6 +403,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup { }} $s] vwait ::total } finally { + after cancel {set ::total timeout} close $s } set ::total @@ -428,6 +436,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup { }} $s] vwait ::total } finally { + after cancel {set ::total timeout} close $s } set ::total @@ -460,6 +469,7 @@ test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup { }} $s] vwait ::total } finally { + after cancel {set ::total timeout} close $s } set ::total @@ -502,6 +512,8 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints { after 100 {set ::total done} }} $s] vwait ::total + after cancel {set ::total timeout} + after cancel {set ::total done} set ::total } -cleanup { close $srv @@ -538,6 +550,8 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints { after 100 {set ::total done} }} $s] vwait ::total + after cancel {set ::total timeout} + after cancel {set ::total done} set ::total } -cleanup { close $srv @@ -576,6 +590,8 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints { after 100 {set ::total done} }} $s] vwait ::total + after cancel {set ::total timeout} + after cancel {set ::total done} set ::total } -cleanup { close $srv -- cgit v0.12