Logo Search packages:      
Sourcecode: tcl8.5 version File versions  Download package

tclWinDde.c

/*
 * 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.
 *
 * RCS: @(#) $Id: tclWinDde.c,v 1.31 2006/09/26 00:05:03 patthoyts Exp $
 */

#include "tclInt.h"
#include <dde.h>
#include <ddeml.h>
#include <tchar.h>

/*
 * 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. */
    char *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.3.2"
#define TCL_DDE_PACKAGE_NAME  "dde"
#define TCL_DDE_SERVICE_NAME  "TclEval"
#define TCL_DDE_EXECUTE_RESULT      "$TCLEVAL$EXECUTE$RESULT"

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,
                      char *serviceName, char *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, char *name,
                      HCONV *ddeConvPtr);
static void       SetDdeError(Tcl_Interp *interp);

int               Tcl_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)
{
    ThreadSpecificData *tsdPtr;

    if (!Tcl_InitStubs(interp, "8.0", 0)) {
      return TCL_ERROR;
    }

    Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL);
    tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_CreateExitHandler(DdeExitProc, NULL);
    return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
}

/*
 *----------------------------------------------------------------------
 *
 * 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, 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, 0);
          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 char *
DdeSetServerName(
    Tcl_Interp *interp,
    char *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 */
    Tcl_Obj *handlerPtr)      /* Name of the optional proc/command to handle
                         * incoming Dde eval's */
{
    int suffix, offset;
    RegisteredInterp *riPtr, *prevPtr;
    Tcl_DString dString;
    char *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 "";
    }

    /*
     * 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) {
      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) {
          OutputDebugString(Tcl_GetStringResult(interp));
          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, name, -1);
                Tcl_DStringAppend(&dString, " #", 2);
                offset = Tcl_DStringLength(&dString);
                Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE);
                actualName = Tcl_DStringValue(&dString);
            }
            sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
          }

          /*
           * See if the name is already in use, if so increment suffix.
           */

          for (n = 0; n < srvCount; ++n) {
            Tcl_Obj* namePtr;

            Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
            if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) {
                suffix++;
                break;
            }
          }
      }
      Tcl_DStringSetLength(&dString,
            offset + (int)strlen(Tcl_DStringValue(&dString)+offset));
    }

    /*
     * We have found a unique name. Now add it to the registry.
     */

    riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
    riPtr->interp = interp;
    riPtr->name = ckalloc((unsigned int) strlen(actualName) + 1);
    riPtr->nextPtr = tsdPtr->interpListPtr;
    riPtr->handlerPtr = handlerPtr;
    if (riPtr->handlerPtr != NULL) {
      Tcl_IncrRefCount(riPtr->handlerPtr);
    }
    tsdPtr->interpListPtr = riPtr;
    strcpy(riPtr->name, actualName);

    if (Tcl_IsSafe(interp)) {
      Tcl_ExposeCommand(interp, "dde", "dde");
    }

    Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
          (ClientData) 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));
      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;
    char *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, 0);
      Tcl_DStringInit(&dString);
      Tcl_DStringSetLength(&dString, len);
      utilString = Tcl_DStringValue(&dString);
      DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
            CP_WINANSI);

      for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
            riPtr = riPtr->nextPtr) {
          if (stricmp(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, 0);
      Tcl_DStringInit(&dString);
      Tcl_DStringSetLength(&dString, len);
      utilString = Tcl_DStringValue(&dString);
      DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
            CP_WINANSI);
      for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
            riPtr = riPtr->nextPtr) {
          if (stricmp(riPtr->name, utilString) == 0) {
            convPtr = (Conversation *) 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((char *) 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) {
          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_WINANSI);
          Tcl_DStringInit(&dString);
          Tcl_DStringSetLength(&dString, len);
          utilString = Tcl_DStringValue(&dString);
          DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
                CP_WINANSI);
          if (stricmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
            returnString =
                  Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
            ddeReturn = DdeCreateDataHandle(ddeInstance, returnString,
                  (DWORD) len+1, 0, ddeItem, CF_TEXT, 0);
          } else {
            if (Tcl_IsSafe(convPtr->riPtr->interp)) {
                ddeReturn = NULL;
            } else {
                Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
                      convPtr->riPtr->interp, utilString, NULL,
                      TCL_GLOBAL_ONLY);
                if (variableObjPtr != NULL) {
                  returnString = Tcl_GetStringFromObj(variableObjPtr,
                        &len);
                  ddeReturn = DdeCreateDataHandle(ddeInstance,
                        returnString, (DWORD) len+1, 0, ddeItem,
                        CF_TEXT, 0);
                } else {
                  ddeReturn = NULL;
                }
            }
          }
          Tcl_DStringFree(&dString);
      }
      return ddeReturn;

    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;

      for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
            && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
          /*
           * Empty loop body.
           */
      }

      if (convPtr == NULL) {
          return (HDDEDATA) DDE_FNOTPROCESSED;
      }

      utilString = (char *) DdeAccessData(hData, &dlen);
      len = dlen;
      ddeObjectPtr = Tcl_NewStringObj(utilString, -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_WINANSI);
          returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance,
                riPtr->name, CP_WINANSI);
      }
      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. */
    char *name,               /* The connection to use. */
    HCONV *ddeConvPtr)
{
    HSZ ddeTopic, ddeService;
    HCONV ddeConv;

    ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0);
    ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);

    ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
    DdeFreeStringHandle(ddeInstance, ddeService);
    DdeFreeStringHandle(ddeInstance, ddeTopic);

    if (ddeConv == (HCONV) NULL) {
      if (interp != NULL) {
          Tcl_AppendResult(interp, "no registered server named \"",
                name, "\"", 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 char *szDdeClientClassName = "TclEval client class";
    static const char *szDdeClientWindowName = "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)es);
#else
      SetWindowLong(hwnd, GWL_USERDATA, (long)es);
#endif
      return (LRESULT) 0L;
    }
    case WM_DDE_ACK:
      return DdeServicesOnAck(hwnd, wParam, lParam);
      break;
    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];

#ifdef _WIN64
    es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
    es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
#endif

    if ((es->service == (ATOM)NULL || es->service == service)
          && (es->topic == (ATOM)NULL || es->topic == topic)) {
      Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
      Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);

      GlobalGetAtomName(service, sz, 255);
      Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
      GlobalGetAtomName(topic, sz, 255);
      Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));

      /*
       * 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)
{
    LRESULT 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,
    char *serviceName,
    char *topicName)
{
    struct DdeEnumServices es;

    es.interp = interp;
    es.result = TCL_OK;
    es.service = (serviceName == NULL)
          ? (ATOM)NULL : GlobalAddAtom(serviceName);
    es.topic = (topicName == NULL) ? (ATOM)NULL : 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)NULL) {
      GlobalDeleteAtom(es.service);
    }
    if (es.topic != (ATOM)NULL) {
      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. */
{
    char *errorMessage;

    switch (DdeGetLastError(ddeInstance)) {
    case DMLERR_DATAACKTIMEOUT:
    case DMLERR_EXECACKTIMEOUT:
    case DMLERR_POKEACKTIMEOUT:
      errorMessage = "remote interpreter did not respond";
      break;
    case DMLERR_BUSY:
      errorMessage = "remote server is busy";
      break;
    case DMLERR_NOTPROCESSED:
      errorMessage = "remote server cannot handle this command";
      break;
    default:
      errorMessage = "dde command failed";
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1));
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_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.
 *
 *----------------------------------------------------------------------
 */

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 */
{
    static CONST char *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 *ddeSrvOptions[] = {
      "-force", "-handler", "--", NULL
    };
    enum DdeSrvOptions {
      DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
    };
    static CONST char *ddeExecOptions[] = {
      "-async", NULL
    };
    static CONST char *ddeReqOptions[] = {
      "-binary", NULL
    };

    int index, i, length;
    int async = 0, binary = 0, exact = 0;
    int result = TCL_OK, firstArg = 0;
    HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
    HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
    HCONV hConv = NULL;
    char *serviceName = NULL, *topicName = NULL, *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++) {
          int argIndex;
          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) {
            exact = 1;
          } 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) {
          int dummy;
          if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
                &dummy) == TCL_OK) {
            async = 1;
            firstArg = 3;
            break;
          }
      }
      /* otherwise... */
      Tcl_WrongNumArgs(interp, 2, objv,
            "?-async? serviceName topicName value");
      return TCL_ERROR;
    case DDE_POKE:
      if (objc != 6) {
          Tcl_WrongNumArgs(interp, 2, objv,
                "serviceName topicName item value");
          return TCL_ERROR;
      }
      firstArg = 2;
      break;
    case DDE_REQUEST:
      if (objc == 5) {
          firstArg = 2;
          break;
      } else if (objc == 6) {
          int dummy;
          if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
                &dummy) == TCL_OK) {
            binary = 1;
            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 {
          int dummy;

          firstArg = 2;
          if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
                &dummy) == TCL_OK) {
            if (objc < 5) {
                goto wrongDdeEvalArgs;
            }
            async = 1;
            firstArg++;
          }
          break;
      }
    }

    Initialize();

    if (firstArg != 1) {
      serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
    } else {
      length = 0;
    }

    if (length == 0) {
      serviceName = NULL;
    } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
      ddeService = DdeCreateStringHandle(ddeInstance, serviceName,
            CP_WINANSI);
    }

    if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
      topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
      if (length == 0) {
          topicName = NULL;
      } else {
          ddeTopic = DdeCreateStringHandle(ddeInstance, topicName,
                CP_WINANSI);
      }
    }

    switch ((enum DdeSubcommands) index) {
    case DDE_SERVERNAME:
      serviceName = DdeSetServerName(interp, serviceName, exact, handlerPtr);
      if (serviceName != NULL) {
          Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1));
      } else {
          Tcl_ResetResult(interp);
      }
      break;

    case DDE_EXECUTE: {
      int dataLength;
      char *dataString = Tcl_GetStringFromObj(objv[firstArg + 2],
            &dataLength);

      if (dataLength == 0) {
          Tcl_SetObjResult(interp,
                Tcl_NewStringObj("cannot execute null data", -1));
          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, dataString,
            (DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
      if (ddeData != NULL) {
          if (async) {
            DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
                  CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
            DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
          } else {
            ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
                  hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
            if (ddeReturn == 0) {
                SetDdeError(interp);
                result = TCL_ERROR;
            }
          }
          DdeFreeDataHandle(ddeData);
      } else {
          SetDdeError(interp);
          result = TCL_ERROR;
      }
      break;
    }
    case DDE_REQUEST: {
      char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);

      if (length == 0) {
          Tcl_SetObjResult(interp,
                Tcl_NewStringObj("cannot request value of null data", -1));
          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, itemString,
                CP_WINANSI);
          if (ddeItem != NULL) {
            ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
                  CF_TEXT, XTYP_REQUEST, 5000, NULL);
            if (ddeData == NULL) {
                SetDdeError(interp);
                result = TCL_ERROR;
            } else {
                DWORD tmp;
                char *dataString = DdeAccessData(ddeData, &tmp);

                if (binary) {
                  returnObjPtr = Tcl_NewByteArrayObj(dataString,
                        (int) tmp);
                } else {
                  returnObjPtr = Tcl_NewStringObj(dataString, -1);
                }
                DdeUnaccessData(ddeData);
                DdeFreeDataHandle(ddeData);
                Tcl_SetObjResult(interp, returnObjPtr);
            }
          } else {
            SetDdeError(interp);
            result = TCL_ERROR;
          }
      }

      break;
    }
    case DDE_POKE: {
      char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
      char *dataString;

      if (length == 0) {
          Tcl_SetObjResult(interp,
                Tcl_NewStringObj("cannot have a null item", -1));
          result = TCL_ERROR;
          goto cleanup;
      }
      dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);

      hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
      DdeFreeStringHandle(ddeInstance, ddeService);
      DdeFreeStringHandle(ddeInstance, ddeTopic);

      if (hConv == NULL) {
          SetDdeError(interp);
          result = TCL_ERROR;
      } else {
          ddeItem = DdeCreateStringHandle(ddeInstance, itemString,
                CP_WINANSI);
          if (ddeItem != NULL) {
            ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
                  hConv, ddeItem, CF_TEXT, 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));
          result = TCL_ERROR;
          goto cleanup;
      }

      objc -= (async + 3);
      objv += (async + 3);

      /*
       * 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 (stricmp(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((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 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_SetResult(riPtr->interp, "permission denied: "
                  "a handler procedure must be defined for use in "
                  "a safe interp", TCL_STATIC);
            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((ClientData) riPtr);
          Tcl_Release((ClientData) 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));
            result = TCL_ERROR;
            goto cleanup;
          }

          objPtr = Tcl_ConcatObj(objc, objv);
          string = Tcl_GetStringFromObj(objPtr, &length);
          ddeItemData = DdeCreateDataHandle(ddeInstance, string,
                (DWORD) length+1, 0, 0, CF_TEXT, 0);

          if (async) {
            ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
                  0xFFFFFFFF, hConv, 0,
                  CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
            DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
          } else {
            ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
                  0xFFFFFFFF, hConv, 0,
                  CF_TEXT, XTYP_EXECUTE, 30000, NULL);
            if (ddeData != 0) {
                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);
            result = TCL_ERROR;
          }

          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, 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);
            Tcl_SetObjLength(resultPtr, length);
            string = Tcl_GetString(resultPtr);
            DdeGetData(ddeData, string, (DWORD) length, 0);
            Tcl_SetObjLength(resultPtr, (int) strlen(string));

            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:
 */

Generated by  Doxygen 1.6.0   Back to index