/* * tclWinDde.c -- * * This file provides functions that implement the "send" command, * allowing commands to be passed from interpreter to interpreter. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #undef USE_TCL_STUBS #define USE_TCL_STUBS #include "tclInt.h" #include #include #ifndef UNICODE # undef CP_WINUNICODE # define CP_WINUNICODE CP_WINANSI # undef Tcl_WinTCharToUtf # define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) # undef Tcl_WinUtfToTChar # define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) #endif #if !defined(NDEBUG) /* test POKE server Implemented for debug mode only */ # undef CBF_FAIL_POKES # define CBF_FAIL_POKES 0 #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 * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLEXPORT /* * The following structure is used to keep track of the interpreters * registered by this process. */ typedef struct RegisteredInterp { struct RegisteredInterp *nextPtr; /* The next interp this application knows * about. */ TCHAR *name; /* Interpreter's name (malloc-ed). */ Tcl_Obj *handlerPtr; /* The server handler command */ Tcl_Interp *interp; /* The interpreter attached to this name. */ } RegisteredInterp; /* * Used to keep track of conversations. */ typedef struct Conversation { struct Conversation *nextPtr; /* The next conversation in the list. */ RegisteredInterp *riPtr; /* The info we know about the conversation. */ HCONV hConv; /* The DDE handle for this conversation. */ Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */ } Conversation; typedef struct DdeEnumServices { Tcl_Interp *interp; int result; ATOM service; ATOM topic; HWND hwnd; } DdeEnumServices; typedef struct ThreadSpecificData { Conversation *currentConversations; /* A list of conversations currently being * processed. */ RegisteredInterp *interpListPtr; /* List of all interpreters registered in the * current process. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The following variables cannot be placed in thread-local storage. The Mutex * ddeMutex guards access to the ddeInstance. */ static HSZ ddeServiceGlobal = 0; static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; #define TCL_DDE_VERSION "1.4.0" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME TEXT("TclEval") #define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") #define DDE_FLAG_ASYNC 1 #define DDE_FLAG_BINARY 2 #define DDE_FLAG_FORCE 4 TCL_DECLARE_MUTEX(ddeMutex) /* * Forward declarations for functions defined later in this file. */ static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); static int DdeCreateClient(struct DdeEnumServices *es); static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); static void DdeExitProc(ClientData clientData); static int DdeGetServicesList(Tcl_Interp *interp, 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); static LRESULT DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam); static void DeleteProc(ClientData clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, const TCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); static int DdeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); EXTERN int Dde_Init(Tcl_Interp *interp); EXTERN int Dde_SafeInit(Tcl_Interp *interp); /* *---------------------------------------------------------------------- * * Dde_Init -- * * This function initializes the dde command. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Dde_Init( Tcl_Interp *interp) { if (!Tcl_InitStubs(interp, "8.6-", 0)) { return TCL_ERROR; } #ifdef UNICODE if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Win32s and Windows 9x are not supported platforms", -1)); return TCL_ERROR; } #endif Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL); } /* *---------------------------------------------------------------------- * * Dde_SafeInit -- * * This function initializes the dde command within a safe interp * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Dde_SafeInit( Tcl_Interp *interp) { int result = Dde_Init(interp); if (result == TCL_OK) { Tcl_HideCommand(interp, "dde", "dde"); } return result; } /* *---------------------------------------------------------------------- * * Initialize -- * * Initialize the global DDE instance. * * Results: * None. * * Side effects: * Registers the DDE server proc. * *---------------------------------------------------------------------- */ static void 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 will take care of * disposing of this entry. */ if (tsdPtr->interpListPtr != NULL) { nameFound = 1; } /* * Make sure that the DDE server is there. This is done only once, add an * exit handler tear it down. */ if (ddeInstance == 0) { Tcl_MutexLock(&ddeMutex); if (ddeInstance == 0) { if (DdeInitialize(&ddeInstance, (PFNCALLBACK) DdeServerProc, CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) { ddeInstance = 0; } } Tcl_MutexUnlock(&ddeMutex); } if ((ddeServiceGlobal == 0) && (nameFound != 0)) { Tcl_MutexLock(&ddeMutex); if ((ddeServiceGlobal == 0) && (nameFound != 0)) { ddeIsServer = 1; Tcl_CreateExitHandler(DdeExitProc, NULL); ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER); } else { ddeIsServer = 0; } Tcl_MutexUnlock(&ddeMutex); } } /* *---------------------------------------------------------------------- * * DdeSetServerName -- * * This function is called to associate an ASCII name with a Dde server. * If the interpreter has already been named, the name replaces the old * one. * * Results: * The return value is the name actually given to the interp. This will * normally be the same as name, but if name was already in use for a Dde * Server then a name of the form "name #2" will be chosen, with a high * enough number to make the name unique. * * Side effects: * Registration info is saved, thereby allowing the "send" command to be * used later to invoke commands in the application. In addition, the * "send" command is created in the application's interpreter. The * registration will be removed automatically if the interpreter is * deleted or the "send" command is removed. * *---------------------------------------------------------------------- */ static const TCHAR * DdeSetServerName( Tcl_Interp *interp, const TCHAR *name, /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ int flags, /* DDE_FLAG_FORCE or 0 */ Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle * incoming Dde eval's */ { int suffix, offset; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; const TCHAR *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; 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 will take care of * disposing of this entry. */ for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL; prevPtr = riPtr, riPtr = riPtr->nextPtr) { if (riPtr->interp == interp) { if (name != NULL) { if (prevPtr == NULL) { tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr; } else { prevPtr->nextPtr = riPtr->nextPtr; } break; } else { /* * The name was NULL, so the caller is asking for the name of * the current interp. */ return riPtr->name; } } } if (name == NULL) { /* * The name was NULL, so the caller is asking for the name of the * current interp, but it doesn't have a name. */ return TEXT(""); } /* * Get the list of currently registered Tcl interpreters by calling the * internal implementation of the 'dde services' command. */ Tcl_DStringInit(&dString); actualName = name; if (!(flags & DDE_FLAG_FORCE)) { r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL); if (r == TCL_OK) { srvListPtr = Tcl_GetObjResult(interp); } if (r == TCL_OK) { r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount, &srvPtrPtr); } if (r != TCL_OK) { Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString); OutputDebugString((TCHAR *) Tcl_DStringValue(&dString)); Tcl_DStringFree(&dString); return NULL; } /* * 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 larger * and larger numbers until we eventually find one that is unique. */ offset = lastSuffix = 0; suffix = 1; while (suffix != lastSuffix) { lastSuffix = suffix; if (suffix > 1) { if (suffix == 2) { Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR)); Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR)); offset = Tcl_DStringLength(&dString); Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE); actualName = (TCHAR *) Tcl_DStringValue(&dString); } _stprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), TEXT("%d"), suffix); } /* * See if the name is already in use, if so increment suffix. */ for (n = 0; n < srvCount; ++n) { Tcl_Obj* namePtr; Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; Tcl_DStringFree(&ds); break; } Tcl_DStringFree(&ds); } } } /* * We have found a unique name. Now add it to the registry. */ riPtr = ckalloc(sizeof(RegisteredInterp)); riPtr->interp = interp; 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; _tcscpy(riPtr->name, actualName); if (Tcl_IsSafe(interp)) { Tcl_ExposeCommand(interp, "dde", "dde"); } Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, riPtr, DeleteProc); if (Tcl_IsSafe(interp)) { Tcl_HideCommand(interp, "dde", "dde"); } Tcl_DStringFree(&dString); /* * Re-initialize with the new name. */ Initialize(); return riPtr->name; } /* *---------------------------------------------------------------------- * * DdeGetRegistrationPtr * * Retrieve the registration info for an interpreter. * * Results: * Returns a pointer to the registration structure or NULL * * Side effects: * None * *---------------------------------------------------------------------- */ static RegisteredInterp * DdeGetRegistrationPtr( Tcl_Interp *interp) { RegisteredInterp *riPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { if (riPtr->interp == interp) { break; } } return riPtr; } /* *---------------------------------------------------------------------- * * DeleteProc * * This function is called when the command "dde" is destroyed. * * Results: * none * * Side effects: * The interpreter given by riPtr is unregistered. * *---------------------------------------------------------------------- */ static void DeleteProc( ClientData clientData) /* The interp we are deleting passed as * ClientData. */ { RegisteredInterp *riPtr = (RegisteredInterp *) clientData; RegisteredInterp *searchPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL; (searchPtr != NULL) && (searchPtr != riPtr); prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) { /* * Empty loop body. */ } if (searchPtr != NULL) { if (prevPtr == NULL) { tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr; } else { prevPtr->nextPtr = searchPtr->nextPtr; } } ckfree(riPtr->name); if (riPtr->handlerPtr) { Tcl_DecrRefCount(riPtr->handlerPtr); } Tcl_EventuallyFree(clientData, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * * ExecuteRemoteObject -- * * Takes the package delivered by DDE and executes it in the server's * interpreter. * * Results: * A list Tcl_Obj * that describes what happened. The first element is * the numerical return code (TCL_ERROR, etc.). The second element is the * result of the script. If the return result was TCL_ERROR, then the * third element will be the value of the global "errorCode", and the * fourth will be the value of the global "errorInfo". The return result * will have a refCount of 0. * * Side effects: * A Tcl script is run, which can cause all kinds of other things to * happen. * *---------------------------------------------------------------------- */ static Tcl_Obj * ExecuteRemoteObject( RegisteredInterp *riPtr, /* Info about this server. */ Tcl_Obj *ddeObjectPtr) /* The object to execute. */ { Tcl_Obj *returnPackagePtr; int result = TCL_OK; if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " "a handler procedure must be defined for use in a safe " "interp", -1)); Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL); result = TCL_ERROR; } if (riPtr->handlerPtr != NULL) { /* * Add the dde request data to the handler proc list. */ Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr); result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr, ddeObjectPtr); if (result == TCL_OK) { ddeObjectPtr = cmdPtr; } } if (result == TCL_OK) { result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL); } returnPackagePtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, returnPackagePtr, Tcl_NewIntObj(result)); Tcl_ListObjAppendElement(NULL, returnPackagePtr, Tcl_GetObjResult(riPtr->interp)); if (result == TCL_ERROR) { Tcl_Obj *errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL, TCL_GLOBAL_ONLY); if (errorObjPtr) { Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); } errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (errorObjPtr) { Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); } } return returnPackagePtr; } /* *---------------------------------------------------------------------- * * DdeServerProc -- * * Handles all transactions for this server. Can handle execute, request, * and connect protocols. Dde will call this routine when a client * attempts to run a dde command using this server. * * Results: * A DDE Handle with the result of the dde command. * * Side effects: * Depending on which command is executed, arbitrary Tcl scripts can be * run. * *---------------------------------------------------------------------- */ static HDDEDATA CALLBACK DdeServerProc( UINT uType, /* The type of DDE transaction we are * performing. */ UINT uFmt, /* The format that data is sent or received */ HCONV hConv, /* The conversation associated with the * current transaction. */ HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type * dependent. */ HDDEDATA hData, /* DDE data. Transaction-type dependent. */ DWORD dwData1, DWORD dwData2) /* Transaction-dependent data. */ { Tcl_DString dString; int len; DWORD dlen; TCHAR *utilString; Tcl_Obj *ddeObjectPtr; HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; Conversation *convPtr, *prevConvPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); switch(uType) { case XTYP_CONNECT: /* * Dde is trying to initialize a conversation with us. Check and make * sure we have a valid topic. */ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { if (_tcsicmp(utilString, riPtr->name) == 0) { Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; } } Tcl_DStringFree(&dString); return (HDDEDATA) FALSE; case XTYP_CONNECT_CONFIRM: /* * 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. */ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { if (_tcsicmp(riPtr->name, utilString) == 0) { convPtr = ckalloc(sizeof(Conversation)); convPtr->nextPtr = tsdPtr->currentConversations; convPtr->returnPackagePtr = NULL; convPtr->hConv = hConv; convPtr->riPtr = riPtr; tsdPtr->currentConversations = convPtr; break; } } Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; case XTYP_DISCONNECT: /* * The client has disconnected from our server. Forget this * conversation. */ for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL; convPtr != NULL; prevConvPtr = convPtr, convPtr = convPtr->nextPtr) { if (hConv == convPtr->hConv) { if (prevConvPtr == NULL) { tsdPtr->currentConversations = convPtr->nextPtr; } else { prevConvPtr->nextPtr = convPtr->nextPtr; } if (convPtr->returnPackagePtr != NULL) { Tcl_DecrRefCount(convPtr->returnPackagePtr); } ckfree(convPtr); break; } } return (HDDEDATA) TRUE; case XTYP_REQUEST: /* * This could be either a request for a value of a Tcl variable, or it * could be the send command requesting the results of the last * execute. */ if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { return (HDDEDATA) FALSE; } ddeReturn = (HDDEDATA) FALSE; for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { /* * Empty loop body. */ } if (convPtr != NULL) { char *returnString; len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { if (uFmt == CF_TEXT) { returnString = Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); } else { returnString = (char *) Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len); len = sizeof(TCHAR) * len + 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); } else { if (Tcl_IsSafe(convPtr->riPtr->interp)) { ddeReturn = NULL; } else { Tcl_DString ds; Tcl_Obj *variableObjPtr; Tcl_WinTCharToUtf(utilString, -1, &ds); variableObjPtr = Tcl_GetVar2Ex( convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, TCL_GLOBAL_ONLY); if (variableObjPtr != NULL) { if (uFmt == CF_TEXT) { returnString = Tcl_GetStringFromObj( variableObjPtr, &len); } else { returnString = (char *) Tcl_GetUnicodeFromObj( variableObjPtr, &len); len = sizeof(TCHAR) * len + 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); } else { ddeReturn = NULL; } Tcl_DStringFree(&ds); } } Tcl_DStringFree(&dString); } return ddeReturn; #if !CBF_FAIL_POKES case XTYP_POKE: /* * This is a poke for a Tcl variable, only implemented in * debug/UNICODE mode. */ ddeReturn = DDE_FNOTPROCESSED; if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { return ddeReturn; } for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { /* * Empty loop body. */ } if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) { Tcl_DString ds; Tcl_Obj *variableObjPtr; len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); Tcl_WinTCharToUtf(utilString, -1, &ds); utilString = (TCHAR *) DdeAccessData(hData, &dlen); if (uFmt == CF_TEXT) { variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); } else { variableObjPtr = Tcl_NewUnicodeObj(utilString, -1); } Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, variableObjPtr, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); Tcl_DStringFree(&dString); ddeReturn = (HDDEDATA) DDE_FACK; } return ddeReturn; #endif case XTYP_EXECUTE: { /* * Execute this script. The results will be saved into a list object * which will be retreived later. See ExecuteRemoteObject. */ Tcl_Obj *returnPackagePtr; char *string; for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { /* * Empty loop body. */ } if (convPtr == NULL) { return (HDDEDATA) DDE_FNOTPROCESSED; } utilString = (TCHAR *) DdeAccessData(hData, &dlen); string = (char *) utilString; if (!dlen) { /* Empty binary array. */ ddeObjectPtr = Tcl_NewObj(); } else if ((dlen & 1) || utilString[(dlen>>1)-1]) { /* Cannot be unicode, so assume utf-8 */ if (!string[dlen-1]) { dlen--; } ddeObjectPtr = Tcl_NewStringObj(string, dlen); } else { /* unicode */ dlen >>= 1; ddeObjectPtr = Tcl_NewUnicodeObj((Tcl_UniChar *)utilString, dlen - 1); } Tcl_IncrRefCount(ddeObjectPtr); DdeUnaccessData(hData); if (convPtr->returnPackagePtr != NULL) { Tcl_DecrRefCount(convPtr->returnPackagePtr); } convPtr->returnPackagePtr = NULL; returnPackagePtr = ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr); Tcl_IncrRefCount(returnPackagePtr); for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { /* * Empty loop body. */ } if (convPtr != NULL) { convPtr->returnPackagePtr = returnPackagePtr; } else { Tcl_DecrRefCount(returnPackagePtr); } Tcl_DecrRefCount(ddeObjectPtr); if (returnPackagePtr == NULL) { return (HDDEDATA) DDE_FNOTPROCESSED; } else { return (HDDEDATA) DDE_FACK; } } case XTYP_WILDCONNECT: { /* * Dde wants a list of services and topics that we support. */ HSZPAIR *returnPtr; int i; int numItems; for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL; i++, riPtr = riPtr->nextPtr) { /* * Empty loop body. */ } numItems = i; ddeReturn = DdeCreateDataHandle(ddeInstance, NULL, (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0); returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen); len = dlen; for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; i++, riPtr = riPtr->nextPtr) { returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance, riPtr->name, CP_WINUNICODE); } returnPtr[i].hszSvc = NULL; returnPtr[i].hszTopic = NULL; DdeUnaccessData(ddeReturn); return ddeReturn; } default: return NULL; } } /* *---------------------------------------------------------------------- * * DdeExitProc -- * * Gets rid of our DDE server when we go away. * * Results: * None. * * Side effects: * The DDE server is deleted. * *---------------------------------------------------------------------- */ static void DdeExitProc( ClientData clientData) /* Not used in this handler. */ { DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER); DdeUninitialize(ddeInstance); ddeInstance = 0; } /* *---------------------------------------------------------------------- * * MakeDdeConnection -- * * This function is a utility used to connect to a DDE server when given * a server name and a topic name. * * Results: * A standard Tcl result. * * Side effects: * Passes back a conversation through ddeConvPtr * *---------------------------------------------------------------------- */ static int MakeDdeConnection( Tcl_Interp *interp, /* Used to report errors. */ const TCHAR *name, /* The connection to use. */ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; HCONV ddeConv; ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINUNICODE); ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); if (ddeConv == (HCONV) NULL) { if (interp != NULL) { Tcl_DString dString; Tcl_WinTCharToUtf(name, -1, &dString); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no registered server named \"%s\"", Tcl_DStringValue(&dString))); Tcl_DStringFree(&dString); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); } return TCL_ERROR; } *ddeConvPtr = ddeConv; return TCL_OK; } /* *---------------------------------------------------------------------- * * DdeGetServicesList -- * * This function obtains the list of DDE services. * * The functions between here and this function are all involved with * handling the DDE callbacks for this. They are: DdeCreateClient, * DdeClientWindowProc, DdeServicesOnAck, and DdeEnumWindowsCallback * * Results: * A standard Tcl result. * * Side effects: * Sets the services list into the interp result. * *---------------------------------------------------------------------- */ static int DdeCreateClient( struct DdeEnumServices *es) { WNDCLASSEX wc; 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); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; wc.cbWndExtra = sizeof(struct DdeEnumServices *); /* * Register and create the callback window. */ RegisterClassEx(&wc); es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName, WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es); return TCL_OK; } static LRESULT CALLBACK DdeClientWindowProc( HWND hwnd, /* What window is the message for */ UINT uMsg, /* The type of message received */ WPARAM wParam, LPARAM lParam) /* (Potentially) our local handle */ { switch (uMsg) { case WM_CREATE: { LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; struct DdeEnumServices *es = (struct DdeEnumServices *) lpcs->lpCreateParams; #ifdef _WIN64 SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es); #else SetWindowLong(hwnd, GWL_USERDATA, (LONG) es); #endif return (LRESULT) 0L; } case WM_DDE_ACK: return DdeServicesOnAck(hwnd, wParam, lParam); default: return DefWindowProc(hwnd, uMsg, wParam, lParam); } } static LRESULT DdeServicesOnAck( HWND hwnd, WPARAM wParam, LPARAM lParam) { HWND hwndRemote = (HWND)wParam; ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); struct DdeEnumServices *es; TCHAR sz[255]; Tcl_DString dString; #ifdef _WIN64 es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); #else es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); #endif if ((es->service == (ATOM)0 || es->service == service) && (es->topic == (ATOM)0 || es->topic == topic)) { Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL); Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); GlobalGetAtomName(service, sz, 255); Tcl_WinTCharToUtf(sz, -1, &dString); Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); Tcl_DStringFree(&dString); GlobalGetAtomName(topic, sz, 255); Tcl_WinTCharToUtf(sz, -1, &dString); Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); Tcl_DStringFree(&dString); /* * Adding the hwnd as a third list element provides a unique * identifier in the case of multiple servers with the name * application and topic names. */ /* * Needs a TIP though: * Tcl_ListObjAppendElement(NULL, matchPtr, * Tcl_NewLongObj((long)hwndRemote)); */ if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); } if (Tcl_ListObjAppendElement(es->interp, resultPtr, matchPtr) == TCL_OK) { Tcl_SetObjResult(es->interp, resultPtr); } } /* * Tell the server we are no longer interested. */ PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L); return 0L; } static BOOL CALLBACK DdeEnumWindowsCallback( HWND hwndTarget, LPARAM lParam) { DWORD_PTR dwResult = 0; struct DdeEnumServices *es = (struct DdeEnumServices *) lParam; SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, &dwResult); return TRUE; } static int DdeGetServicesList( Tcl_Interp *interp, const TCHAR *serviceName, const TCHAR *topicName) { struct DdeEnumServices es; es.interp = interp; es.result = TCL_OK; es.service = (serviceName == NULL) ? (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) { GlobalDeleteAtom(es.service); } if (es.topic != (ATOM)0) { GlobalDeleteAtom(es.topic); } return es.result; } /* *---------------------------------------------------------------------- * * SetDdeError -- * * Sets the interp result to a cogent error message describing the last * DDE error. * * Results: * None. * * Side effects: * The interp's result object is changed. * *---------------------------------------------------------------------- */ static void SetDdeError( Tcl_Interp *interp) /* The interp to put the message in. */ { const char *errorMessage, *errorCode; switch (DdeGetLastError(ddeInstance)) { case DMLERR_DATAACKTIMEOUT: case DMLERR_EXECACKTIMEOUT: case DMLERR_POKEACKTIMEOUT: errorMessage = "remote interpreter did not respond"; errorCode = "TIMEOUT"; break; case DMLERR_BUSY: errorMessage = "remote server is busy"; errorCode = "BUSY"; break; case DMLERR_NOTPROCESSED: errorMessage = "remote server cannot handle this command"; errorCode = "NOCANDO"; break; default: errorMessage = "dde command failed"; errorCode = "FAILED"; } Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL); } /* *---------------------------------------------------------------------- * * DdeObjCmd -- * * This function is invoked to process the "dde" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ 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 */ { static const char *const ddeCommands[] = { "servername", "execute", "poke", "request", "services", "eval", (char *) NULL}; enum DdeSubcommands { DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES, DDE_EVAL }; static const char *const ddeSrvOptions[] = { "-force", "-handler", "--", NULL }; enum DdeSrvOptions { DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST, }; static const char *const ddeExecOptions[] = { "-async", "-binary", NULL }; enum DdeExecOptions { DDE_EXEC_ASYNC, DDE_EXEC_BINARY }; static const char *const ddeEvalOptions[] = { "-async", NULL }; static const char *const ddeReqOptions[] = { "-binary", NULL }; int index, i, length, argIndex; int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; const TCHAR *serviceName = NULL, *topicName = NULL; const char *string; DWORD ddeResult; Tcl_Obj *objPtr, *handlerPtr = NULL; /* * Initialize DDE server/client */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: for (i = 2; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions, "option", 0, &argIndex) != TCL_OK) { /* * If it is the last argument, it might be a server name * instead of a bad argument. */ if (i != objc-1) { return TCL_ERROR; } Tcl_ResetResult(interp); break; } if (argIndex == DDE_SERVERNAME_EXACT) { flags |= DDE_FLAG_FORCE; } else if (argIndex == DDE_SERVERNAME_HANDLER) { if ((objc - i) == 1) { /* return current handler */ RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp); if (riPtr && riPtr->handlerPtr) { Tcl_SetObjResult(interp, riPtr->handlerPtr); } else { Tcl_ResetResult(interp); } return TCL_OK; } handlerPtr = objv[++i]; } else if (argIndex == DDE_SERVERNAME_LAST) { i++; break; } } if ((objc - i) > 1) { Tcl_ResetResult(interp); Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?-handler proc? ?--? ?serverName?"); return TCL_ERROR; } firstArg = (objc == i) ? 1 : i; break; case DDE_EXECUTE: if (objc == 5) { firstArg = 2; break; } else if (objc >= 6 && objc <= 7) { firstArg = objc - 3; for (i = 2; i < firstArg; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions, "option", 0, &argIndex) != TCL_OK) { goto wrongDdeExecuteArgs; } if (argIndex == DDE_EXEC_ASYNC) { flags |= DDE_FLAG_ASYNC; } else { flags |= DDE_FLAG_BINARY; } } break; } /* otherwise... */ wrongDdeExecuteArgs: Tcl_WrongNumArgs(interp, 2, objv, "?-async? ?-binary? serviceName topicName value"); return TCL_ERROR; case DDE_POKE: if (objc == 6) { firstArg = 2; break; } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { flags |= DDE_FLAG_BINARY; firstArg = 3; break; } /* * Otherwise... */ Tcl_WrongNumArgs(interp, 2, objv, "?-binary? serviceName topicName item value"); return TCL_ERROR; case DDE_REQUEST: if (objc == 5) { firstArg = 2; break; } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { flags |= DDE_FLAG_BINARY; firstArg = 3; break; } /* * Otherwise ... */ Tcl_WrongNumArgs(interp, 2, objv, "?-binary? serviceName topicName value"); return TCL_ERROR; case DDE_SERVICES: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "serviceName topicName"); return TCL_ERROR; } firstArg = 2; break; case DDE_EVAL: if (objc < 4) { wrongDdeEvalArgs: Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args"); return TCL_ERROR; } else { firstArg = 2; if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option", 0, &argIndex) == TCL_OK) { if (objc < 5) { goto wrongDdeEvalArgs; } flags |= DDE_FLAG_ASYNC; firstArg++; } break; } } Initialize(); if (firstArg != 1) { #ifdef UNICODE serviceName = Tcl_GetUnicodeFromObj(objv[firstArg], &length); #else serviceName = Tcl_GetStringFromObj(objv[firstArg], &length); #endif } else { length = 0; } if (length == 0) { serviceName = NULL; } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName, CP_WINUNICODE); } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { #ifdef UNICODE topicName = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 1], &length); #else topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length); #endif if (length == 0) { topicName = NULL; } else { ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName, CP_WINUNICODE); } } switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: serviceName = DdeSetServerName(interp, serviceName, flags, handlerPtr); if (serviceName != NULL) { #ifdef UNICODE Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1)); #else Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1)); #endif } else { Tcl_ResetResult(interp); } break; case DDE_EXECUTE: { int dataLength; const Tcl_UniChar *dataString; if (flags & DDE_FLAG_BINARY) { dataString = (const Tcl_UniChar *) Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); } else { dataString = Tcl_GetUnicodeFromObj(objv[firstArg + 2], &dataLength); dataLength = (dataLength + 1) * sizeof(Tcl_UniChar); } if (dataLength <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot execute null data", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; break; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); if (hConv == NULL) { SetDdeError(interp); result = TCL_ERROR; break; } ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString, (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0); if (ddeData != NULL) { if (flags & DDE_FLAG_ASYNC) { DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeReturn == 0) { SetDdeError(interp); result = TCL_ERROR; } } DdeFreeDataHandle(ddeData); } else { SetDdeError(interp); result = TCL_ERROR; } break; } case DDE_REQUEST: { #ifdef UNICODE const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], &length); #else const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length); #endif if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot request value of null data", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; goto cleanup; } 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, (void *) itemString, CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { DWORD tmp; const Tcl_UniChar *dataString = (const Tcl_UniChar *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); } else { tmp >>= 1; if (tmp && !dataString[(tmp-1)]) { --tmp; } returnObjPtr = Tcl_NewUnicodeObj(dataString, (int) tmp); } DdeUnaccessData(ddeData); DdeFreeDataHandle(ddeData); Tcl_SetObjResult(interp, returnObjPtr); } } else { SetDdeError(interp); result = TCL_ERROR; } } break; } case DDE_POKE: { #ifdef UNICODE const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], &length); #else const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length); #endif BYTE *dataString; if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot have a null item", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; goto cleanup; } if (flags & DDE_FLAG_BINARY) { dataString = (BYTE *) Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); } else { dataString = (BYTE *) Tcl_GetUnicodeFromObj(objv[firstArg + 3], &length); length = 2 * length + 1; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); if (hConv == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(dataString, (DWORD) length, hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; } } else { SetDdeError(interp); result = TCL_ERROR; } } break; } case DDE_SERVICES: result = DdeGetServicesList(interp, serviceName, topicName); break; case DDE_EVAL: { RegisteredInterp *riPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (serviceName == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid service name \"\"", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); result = TCL_ERROR; goto cleanup; } objc -= firstArg + 1; objv += firstArg + 1; /* * 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 deallocated objects. */ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { if (_tcsicmp(serviceName, riPtr->name) == 0) { break; } } if (riPtr != NULL) { Tcl_Interp *sendInterp; /* * This command is to a local interp. No need to go through the * server. */ Tcl_Preserve(riPtr); sendInterp = riPtr->interp; Tcl_Preserve(sendInterp); /* * Don't exchange objects between interps. The target interp would * 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. */ if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( "permission denied: a handler procedure must be" " defined for use in a safe interp", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK", NULL); result = TCL_ERROR; } if (result == TCL_OK) { if (objc == 1) objPtr = objv[0]; else { objPtr = Tcl_ConcatObj(objc, objv); } if (riPtr->handlerPtr != NULL) { /* add the dde request data to the handler proc list */ /* *result = Tcl_ListObjReplace(sendInterp, objPtr, 0, 0, 1, * &(riPtr->handlerPtr)); */ Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr); result = Tcl_ListObjAppendElement(sendInterp, cmdPtr, objPtr); if (result == TCL_OK) { objPtr = cmdPtr; } } } if (result == TCL_OK) { Tcl_IncrRefCount(objPtr); result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(objPtr); } if (interp != sendInterp) { if (result == TCL_ERROR) { /* * An error occurred, so transfer error information from * the destination interpreter back to our interpreter. */ Tcl_ResetResult(interp); objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (objPtr) { string = Tcl_GetStringFromObj(objPtr, &length); Tcl_AddObjErrorInfo(interp, string, length); } objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL, TCL_GLOBAL_ONLY); if (objPtr) { Tcl_SetObjErrorCode(interp, objPtr); } } Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); } Tcl_Release(riPtr); Tcl_Release(sendInterp); } else { /* * 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) { invalidServerResponse: Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid data returned from server", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL); result = TCL_ERROR; goto cleanup; } objPtr = Tcl_ConcatObj(objc, objv); string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length); ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, (DWORD) 2*length+2, 0, 0, CF_UNICODETEXT, 0); if (flags & DDE_FLAG_ASYNC) { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { ddeCookie = DdeCreateStringHandle(ddeInstance, TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); } } Tcl_DecrRefCount(objPtr); if (ddeData == 0) { SetDdeError(interp); result = TCL_ERROR; goto cleanup; } if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; Tcl_UniChar *ddeDataString; /* * The return handle has a two or four element list in it. The * first element is the return code (TCL_OK, TCL_ERROR, etc.). * The second is the result of the script. If the return code * is TCL_ERROR, then the third 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); ddeDataString = ckalloc(length); DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); length = (length >> 1) - 1; resultPtr = Tcl_NewUnicodeObj(ddeDataString, length); ckfree(ddeDataString); if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); goto invalidServerResponse; } if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) { Tcl_DecrRefCount(resultPtr); goto invalidServerResponse; } if (result == TCL_ERROR) { Tcl_ResetResult(interp); if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); goto invalidServerResponse; } length = -1; string = Tcl_GetStringFromObj(objPtr, &length); Tcl_AddObjErrorInfo(interp, string, length); Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr); Tcl_SetObjErrorCode(interp, objPtr); } if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); goto invalidServerResponse; } Tcl_SetObjResult(interp, objPtr); Tcl_DecrRefCount(resultPtr); } } } } cleanup: if (ddeCookie != NULL) { DdeFreeStringHandle(ddeInstance, ddeCookie); } if (ddeItem != NULL) { DdeFreeStringHandle(ddeInstance, ddeItem); } if (ddeItemData != NULL) { DdeFreeDataHandle(ddeItemData); } if (ddeData != NULL) { DdeFreeDataHandle(ddeData); } if (hConv != NULL) { DdeDisconnect(hConv); } return result; } /* * Local variables: * mode: c * indent-tabs-mode: t * tab-width: 8 * c-basic-offset: 4 * fill-column: 78 * End: */