sl@0: /* 
sl@0:  * tclWinDde.c --
sl@0:  *
sl@0:  *	This file provides procedures that implement the "send"
sl@0:  *	command, allowing commands to be passed from interpreter
sl@0:  *	to interpreter.
sl@0:  *
sl@0:  * Copyright (c) 1997 by Sun Microsystems, Inc.
sl@0:  *
sl@0:  * See the file "license.terms" for information on usage and redistribution
sl@0:  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0:  *
sl@0:  * RCS: @(#) $Id: tclWinDde.c,v 1.13.2.7 2006/04/05 20:50:46 dgp Exp $
sl@0:  */
sl@0: 
sl@0: #include "tclPort.h"
sl@0: #include <dde.h>
sl@0: #include <ddeml.h>
sl@0: #include <tchar.h>
sl@0: 
sl@0: /*
sl@0:  * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
sl@0:  * Registry_Init declaration is in the source file itself, which is only
sl@0:  * accessed when we are building a library.
sl@0:  */
sl@0: 
sl@0: #undef TCL_STORAGE_CLASS
sl@0: #define TCL_STORAGE_CLASS DLLEXPORT
sl@0: 
sl@0: /* 
sl@0:  * The following structure is used to keep track of the interpreters
sl@0:  * registered by this process.
sl@0:  */
sl@0: 
sl@0: typedef struct RegisteredInterp {
sl@0:     struct RegisteredInterp *nextPtr;
sl@0: 				/* The next interp this application knows
sl@0: 				 * about. */
sl@0:     char *name;			/* Interpreter's name (malloc-ed). */
sl@0:     Tcl_Interp *interp;		/* The interpreter attached to this name. */
sl@0: } RegisteredInterp;
sl@0: 
sl@0: /*
sl@0:  * Used to keep track of conversations.
sl@0:  */
sl@0: 
sl@0: typedef struct Conversation {
sl@0:     struct Conversation *nextPtr;
sl@0: 				/* The next conversation in the list. */
sl@0:     RegisteredInterp *riPtr;	/* The info we know about the conversation. */
sl@0:     HCONV hConv;		/* The DDE handle for this conversation. */
sl@0:     Tcl_Obj *returnPackagePtr;	/* The result package for this conversation. */
sl@0: } Conversation;
sl@0: 
sl@0: typedef struct ThreadSpecificData {
sl@0:     Conversation *currentConversations;
sl@0:                                 /* A list of conversations currently
sl@0: 				 * being processed. */
sl@0:     RegisteredInterp *interpListPtr;
sl@0:                                 /* List of all interpreters registered
sl@0: 				 * in the current process. */
sl@0: } ThreadSpecificData;
sl@0: static Tcl_ThreadDataKey dataKey;
sl@0: 
sl@0: /*
sl@0:  * The following variables cannot be placed in thread-local storage.
sl@0:  * The Mutex ddeMutex guards access to the ddeInstance.
sl@0:  */
sl@0: static HSZ ddeServiceGlobal = 0;
sl@0: static DWORD ddeInstance;       /* The application instance handle given
sl@0: 				 * to us by DdeInitialize. */
sl@0: static int ddeIsServer = 0;
sl@0: 
sl@0: #define TCL_DDE_VERSION "1.2.4"
sl@0: #define TCL_DDE_PACKAGE_NAME "dde"
sl@0: #define TCL_DDE_SERVICE_NAME "TclEval"
sl@0: 
sl@0: TCL_DECLARE_MUTEX(ddeMutex)
sl@0: 
sl@0: /*
sl@0:  * Forward declarations for procedures defined later in this file.
sl@0:  */
sl@0: 
sl@0: static void		    DdeExitProc _ANSI_ARGS_((ClientData clientData));
sl@0: static void		    DeleteProc _ANSI_ARGS_((ClientData clientData));
sl@0: static Tcl_Obj *	    ExecuteRemoteObject _ANSI_ARGS_((
sl@0: 				RegisteredInterp *riPtr, 
sl@0: 				Tcl_Obj *ddeObjectPtr));
sl@0: static int		    MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 				char *name, HCONV *ddeConvPtr));
sl@0: static HDDEDATA CALLBACK    DdeServerProc _ANSI_ARGS_((UINT uType,
sl@0: 				UINT uFmt, HCONV hConv, HSZ ddeTopic,
sl@0: 				HSZ ddeItem, HDDEDATA hData, DWORD dwData1, 
sl@0: 				DWORD dwData2));
sl@0: static void		    SetDdeError _ANSI_ARGS_((Tcl_Interp *interp));
sl@0: static int                  DdeGetServicesList _ANSI_ARGS_((
sl@0: 				Tcl_Interp *interp,
sl@0: 				char *serviceName,
sl@0: 				char *topicName));
sl@0: int Tcl_DdeObjCmd(ClientData clientData,	/* Used only for deletion */
sl@0: 	Tcl_Interp *interp,		/* The interp we are sending from */
sl@0: 	int objc,			/* Number of arguments */
sl@0: 	Tcl_Obj *CONST objv[]);	/* The arguments */
sl@0: 
sl@0: EXTERN int Dde_Init(Tcl_Interp *interp);
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Dde_Init --
sl@0:  *
sl@0:  *	This procedure initializes the dde command.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: Dde_Init(
sl@0:     Tcl_Interp *interp)
sl@0: {
sl@0:     ThreadSpecificData *tsdPtr;
sl@0: 
sl@0:     if (!Tcl_InitStubs(interp, "8.0", 0)) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL);
sl@0: 
sl@0:     tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0: 
sl@0:     Tcl_CreateExitHandler(DdeExitProc, NULL);
sl@0: 
sl@0:     return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Initialize --
sl@0:  *
sl@0:  *	Initialize the global DDE instance.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Registers the DDE server proc.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: Initialize(void)
sl@0: {
sl@0:     int nameFound = 0;
sl@0:     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0:     
sl@0:     /*
sl@0:      * See if the application is already registered; if so, remove its
sl@0:      * current name from the registry. The deletion of the command
sl@0:      * will take care of disposing of this entry.
sl@0:      */
sl@0: 
sl@0:     if (tsdPtr->interpListPtr != NULL) {
sl@0: 	nameFound = 1;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Make sure that the DDE server is there. This is done only once,
sl@0:      * add an exit handler tear it down.
sl@0:      */
sl@0: 
sl@0:     if (ddeInstance == 0) {
sl@0: 	Tcl_MutexLock(&ddeMutex);
sl@0: 	if (ddeInstance == 0) {
sl@0: 	    if (DdeInitialize(&ddeInstance, DdeServerProc,
sl@0: 		    CBF_SKIP_REGISTRATIONS
sl@0: 		    | CBF_SKIP_UNREGISTRATIONS
sl@0: 		    | CBF_FAIL_POKES, 0) 
sl@0: 		    != DMLERR_NO_ERROR) {
sl@0: 		ddeInstance = 0;
sl@0: 	    }
sl@0: 	}
sl@0: 	Tcl_MutexUnlock(&ddeMutex);
sl@0:     }
sl@0:     if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
sl@0: 	Tcl_MutexLock(&ddeMutex);
sl@0: 	if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
sl@0: 	    ddeIsServer = 1;
sl@0: 	    Tcl_CreateExitHandler(DdeExitProc, NULL);
sl@0: 	    ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, \
sl@0: 		    TCL_DDE_SERVICE_NAME, 0);
sl@0: 	    DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
sl@0: 	} else {
sl@0: 	    ddeIsServer = 0;
sl@0: 	}
sl@0: 	Tcl_MutexUnlock(&ddeMutex);
sl@0:     }
sl@0: }    
sl@0: 
sl@0: /*
sl@0:  *--------------------------------------------------------------
sl@0:  *
sl@0:  * DdeSetServerName --
sl@0:  *
sl@0:  *	This procedure is called to associate an ASCII name with a Dde
sl@0:  *	server.  If the interpreter has already been named, the
sl@0:  *	name replaces the old one.
sl@0:  *
sl@0:  * Results:
sl@0:  *	The return value is the name actually given to the interp.
sl@0:  *	This will normally be the same as name, but if name was already
sl@0:  *	in use for a Dde Server then a name of the form "name #2" will
sl@0:  *	be chosen,  with a high enough number to make the name unique.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Registration info is saved, thereby allowing the "send" command
sl@0:  *	to be used later to invoke commands in the application.  In
sl@0:  *	addition, the "send" command is created in the application's
sl@0:  *	interpreter.  The registration will be removed automatically
sl@0:  *	if the interpreter is deleted or the "send" command is removed.
sl@0:  *
sl@0:  *--------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static char *
sl@0: DdeSetServerName(
sl@0:     Tcl_Interp *interp,
sl@0:     char *name			/* The name that will be used to
sl@0: 				 * refer to the interpreter in later
sl@0: 				 * "send" commands.  Must be globally
sl@0: 				 * unique. */
sl@0:     )
sl@0: {
sl@0:     int suffix, offset;
sl@0:     RegisteredInterp *riPtr, *prevPtr;
sl@0:     Tcl_DString dString;
sl@0:     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0: 
sl@0:     /*
sl@0:      * See if the application is already registered; if so, remove its
sl@0:      * current name from the registry. The deletion of the command
sl@0:      * will take care of disposing of this entry.
sl@0:      */
sl@0: 
sl@0:     for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL; 
sl@0: 	    prevPtr = riPtr, riPtr = riPtr->nextPtr) {
sl@0: 	if (riPtr->interp == interp) {
sl@0: 	    if (name != NULL) {
sl@0: 		if (prevPtr == NULL) {
sl@0: 		    tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
sl@0: 		} else {
sl@0: 		    prevPtr->nextPtr = riPtr->nextPtr;
sl@0: 		}
sl@0: 		break;
sl@0: 	    } else {
sl@0: 		/*
sl@0: 		 * the name was NULL, so the caller is asking for
sl@0: 		 * the name of the current interp.
sl@0: 		 */
sl@0: 
sl@0: 		return riPtr->name;
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     if (name == NULL) {
sl@0: 	/*
sl@0: 	 * the name was NULL, so the caller is asking for
sl@0: 	 * the name of the current interp, but it doesn't
sl@0: 	 * have a name.
sl@0: 	 */
sl@0: 
sl@0: 	return "";
sl@0:     }
sl@0:     
sl@0:     /*
sl@0:      * Pick a name to use for the application.  Use "name" if it's not
sl@0:      * already in use.  Otherwise add a suffix such as " #2", trying
sl@0:      * larger and larger numbers until we eventually find one that is
sl@0:      * unique.
sl@0:      */
sl@0: 
sl@0:     suffix = 1;
sl@0:     offset = 0;
sl@0:     Tcl_DStringInit(&dString);
sl@0: 
sl@0:     /*
sl@0:      * We have found a unique name. Now add it to the registry.
sl@0:      */
sl@0: 
sl@0:     riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
sl@0:     riPtr->interp = interp;
sl@0:     riPtr->name = ckalloc((unsigned int) strlen(name) + 1);
sl@0:     riPtr->nextPtr = tsdPtr->interpListPtr;
sl@0:     tsdPtr->interpListPtr = riPtr;
sl@0:     strcpy(riPtr->name, name);
sl@0: 
sl@0:     Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
sl@0: 	    (ClientData) riPtr, DeleteProc);
sl@0:     if (Tcl_IsSafe(interp)) {
sl@0: 	Tcl_HideCommand(interp, "dde", "dde");
sl@0:     }
sl@0:     Tcl_DStringFree(&dString);
sl@0: 
sl@0:     /*
sl@0:      * re-initialize with the new name
sl@0:      */
sl@0:     Initialize();
sl@0:     
sl@0:     return riPtr->name;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *--------------------------------------------------------------
sl@0:  *
sl@0:  * DeleteProc
sl@0:  *
sl@0:  *	This procedure is called when the command "dde" is destroyed.
sl@0:  *
sl@0:  * Results:
sl@0:  *	none
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	The interpreter given by riPtr is unregistered.
sl@0:  *
sl@0:  *--------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: DeleteProc(clientData)
sl@0:     ClientData clientData;	/* The interp we are deleting passed
sl@0: 				 * as ClientData. */
sl@0: {
sl@0:     RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
sl@0:     RegisteredInterp *searchPtr, *prevPtr;
sl@0:     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0: 
sl@0:     for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
sl@0: 	    (searchPtr != NULL) && (searchPtr != riPtr);
sl@0: 	    prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
sl@0: 	/*
sl@0: 	 * Empty loop body.
sl@0: 	 */
sl@0:     }
sl@0: 
sl@0:     if (searchPtr != NULL) {
sl@0: 	if (prevPtr == NULL) {
sl@0: 	    tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
sl@0: 	} else {
sl@0: 	    prevPtr->nextPtr = searchPtr->nextPtr;
sl@0: 	}
sl@0:     }
sl@0:     ckfree(riPtr->name);
sl@0:     Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *--------------------------------------------------------------
sl@0:  *
sl@0:  * ExecuteRemoteObject --
sl@0:  *
sl@0:  *	Takes the package delivered by DDE and executes it in
sl@0:  *	the server's interpreter.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A list Tcl_Obj * that describes what happened. The first
sl@0:  *	element is the numerical return code (TCL_ERROR, etc.).
sl@0:  *	The second element is the result of the script. If the
sl@0:  *	return result was TCL_ERROR, then the third element
sl@0:  *	will be the value of the global "errorCode", and the
sl@0:  *	fourth will be the value of the global "errorInfo".
sl@0:  *	The return result will have a refCount of 0.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	A Tcl script is run, which can cause all kinds of other
sl@0:  *	things to happen.
sl@0:  *
sl@0:  *--------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static Tcl_Obj *
sl@0: ExecuteRemoteObject(
sl@0:     RegisteredInterp *riPtr,	    /* Info about this server. */
sl@0:     Tcl_Obj *ddeObjectPtr)	    /* The object to execute. */
sl@0: {
sl@0:     Tcl_Obj *errorObjPtr;
sl@0:     Tcl_Obj *returnPackagePtr;
sl@0:     int result;
sl@0: 
sl@0:     result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
sl@0:     returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0:     Tcl_ListObjAppendElement(NULL, returnPackagePtr,
sl@0: 	    Tcl_NewIntObj(result));
sl@0:     Tcl_ListObjAppendElement(NULL, returnPackagePtr,
sl@0: 	    Tcl_GetObjResult(riPtr->interp));
sl@0:     if (result == TCL_ERROR) {
sl@0: 	errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
sl@0: 		TCL_GLOBAL_ONLY);
sl@0: 	Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
sl@0: 	errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
sl@0: 		TCL_GLOBAL_ONLY);
sl@0:         Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
sl@0:     }
sl@0: 
sl@0:     return returnPackagePtr;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *--------------------------------------------------------------
sl@0:  *
sl@0:  * DdeServerProc --
sl@0:  *
sl@0:  *	Handles all transactions for this server. Can handle
sl@0:  *	execute, request, and connect protocols. Dde will
sl@0:  *	call this routine when a client attempts to run a dde
sl@0:  *	command using this server.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A DDE Handle with the result of the dde command.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Depending on which command is executed, arbitrary
sl@0:  *	Tcl scripts can be run.
sl@0:  *
sl@0:  *--------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static HDDEDATA CALLBACK
sl@0: DdeServerProc (
sl@0:     UINT uType,			/* The type of DDE transaction we
sl@0: 				 * are performing. */
sl@0:     UINT uFmt,			/* The format that data is sent or
sl@0: 				 * received. */
sl@0:     HCONV hConv,		/* The conversation associated with the 
sl@0: 				 * current transaction. */
sl@0:     HSZ ddeTopic,		/* A string handle. Transaction-type 
sl@0: 				 * dependent. */
sl@0:     HSZ ddeItem,		/* A string handle. Transaction-type 
sl@0: 				 * dependent. */
sl@0:     HDDEDATA hData,		/* DDE data. Transaction-type dependent. */
sl@0:     DWORD dwData1,		/* Transaction-dependent data. */
sl@0:     DWORD dwData2)		/* Transaction-dependent data. */
sl@0: {
sl@0:     Tcl_DString dString;
sl@0:     int len;
sl@0:     DWORD dlen;
sl@0:     char *utilString;
sl@0:     Tcl_Obj *ddeObjectPtr;
sl@0:     HDDEDATA ddeReturn = NULL;
sl@0:     RegisteredInterp *riPtr;
sl@0:     Conversation *convPtr, *prevConvPtr;
sl@0:     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0: 
sl@0:     switch(uType) {
sl@0: 	case XTYP_CONNECT:
sl@0: 
sl@0: 	    /*
sl@0: 	     * Dde is trying to initialize a conversation with us. Check
sl@0: 	     * and make sure we have a valid topic.
sl@0: 	     */
sl@0: 
sl@0: 	    len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
sl@0: 	    Tcl_DStringInit(&dString);
sl@0: 	    Tcl_DStringSetLength(&dString, len);
sl@0: 	    utilString = Tcl_DStringValue(&dString);
sl@0: 	    DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
sl@0: 		    CP_WINANSI);
sl@0: 
sl@0: 	    for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
sl@0: 		    riPtr = riPtr->nextPtr) {
sl@0: 		if (stricmp(utilString, riPtr->name) == 0) {
sl@0: 		    Tcl_DStringFree(&dString);
sl@0: 		    return (HDDEDATA) TRUE;
sl@0: 		}
sl@0: 	    }
sl@0: 
sl@0: 	    Tcl_DStringFree(&dString);
sl@0: 	    return (HDDEDATA) FALSE;
sl@0: 
sl@0: 	case XTYP_CONNECT_CONFIRM:
sl@0: 
sl@0: 	    /*
sl@0: 	     * Dde has decided that we can connect, so it gives us a 
sl@0: 	     * conversation handle. We need to keep track of it
sl@0: 	     * so we know which execution result to return in an
sl@0: 	     * XTYP_REQUEST.
sl@0: 	     */
sl@0: 
sl@0: 	    len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
sl@0: 	    Tcl_DStringInit(&dString);
sl@0: 	    Tcl_DStringSetLength(&dString, len);
sl@0: 	    utilString = Tcl_DStringValue(&dString);
sl@0: 	    DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, 
sl@0: 		    CP_WINANSI);
sl@0: 	    for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; 
sl@0: 		    riPtr = riPtr->nextPtr) {
sl@0: 		if (stricmp(riPtr->name, utilString) == 0) {
sl@0: 		    convPtr = (Conversation *) ckalloc(sizeof(Conversation));
sl@0: 		    convPtr->nextPtr = tsdPtr->currentConversations;
sl@0: 		    convPtr->returnPackagePtr = NULL;
sl@0: 		    convPtr->hConv = hConv;
sl@0: 		    convPtr->riPtr = riPtr;
sl@0: 		    tsdPtr->currentConversations = convPtr;
sl@0: 		    break;
sl@0: 		}
sl@0: 	    }
sl@0: 	    Tcl_DStringFree(&dString);
sl@0: 	    return (HDDEDATA) TRUE;
sl@0: 
sl@0: 	case XTYP_DISCONNECT:
sl@0: 
sl@0: 	    /*
sl@0: 	     * The client has disconnected from our server. Forget this
sl@0: 	     * conversation.
sl@0: 	     */
sl@0: 
sl@0: 	    for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
sl@0: 		    convPtr != NULL; 
sl@0: 		    prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
sl@0: 		if (hConv == convPtr->hConv) {
sl@0: 		    if (prevConvPtr == NULL) {
sl@0: 			tsdPtr->currentConversations = convPtr->nextPtr;
sl@0: 		    } else {
sl@0: 			prevConvPtr->nextPtr = convPtr->nextPtr;
sl@0: 		    }
sl@0: 		    if (convPtr->returnPackagePtr != NULL) {
sl@0: 			Tcl_DecrRefCount(convPtr->returnPackagePtr);
sl@0: 		    }
sl@0: 		    ckfree((char *) convPtr);
sl@0: 		    break;
sl@0: 		}
sl@0: 	    }
sl@0: 	    return (HDDEDATA) TRUE;
sl@0: 
sl@0: 	case XTYP_REQUEST:
sl@0: 
sl@0: 	    /*
sl@0: 	     * This could be either a request for a value of a Tcl variable,
sl@0: 	     * or it could be the send command requesting the results of the
sl@0: 	     * last execute.
sl@0: 	     */
sl@0: 
sl@0: 	    if (uFmt != CF_TEXT) {
sl@0: 		return (HDDEDATA) FALSE;
sl@0: 	    }
sl@0: 
sl@0: 	    ddeReturn = (HDDEDATA) FALSE;
sl@0: 	    for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
sl@0: 		    && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
sl@0: 		/*
sl@0: 		 * Empty loop body.
sl@0: 		 */
sl@0: 	    }
sl@0: 
sl@0: 	    if (convPtr != NULL) {
sl@0: 		char *returnString;
sl@0: 
sl@0: 		len = DdeQueryString(ddeInstance, ddeItem, NULL, 0,
sl@0: 			CP_WINANSI);
sl@0: 		Tcl_DStringInit(&dString);
sl@0: 		Tcl_DStringSetLength(&dString, len);
sl@0: 		utilString = Tcl_DStringValue(&dString);
sl@0: 		DdeQueryString(ddeInstance, ddeItem, utilString, 
sl@0:                         (DWORD) len + 1, CP_WINANSI);
sl@0: 		if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) {
sl@0: 		    returnString =
sl@0: 		        Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
sl@0: 		    ddeReturn = DdeCreateDataHandle(ddeInstance,
sl@0: 			    returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT,
sl@0: 			    0);
sl@0: 		} else {
sl@0: 		    Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
sl@0: 			    convPtr->riPtr->interp, utilString, NULL, 
sl@0: 			    TCL_GLOBAL_ONLY);
sl@0: 		    if (variableObjPtr != NULL) {
sl@0: 			returnString = Tcl_GetStringFromObj(variableObjPtr,
sl@0: 				&len);
sl@0: 			ddeReturn = DdeCreateDataHandle(ddeInstance,
sl@0: 				returnString, (DWORD) len+1, 0, ddeItem,
sl@0: 				CF_TEXT, 0);
sl@0: 		    } else {
sl@0: 			ddeReturn = NULL;
sl@0: 		    }
sl@0: 		}
sl@0: 		Tcl_DStringFree(&dString);
sl@0: 	    }
sl@0: 	    return ddeReturn;
sl@0: 
sl@0: 	case XTYP_EXECUTE: {
sl@0: 
sl@0: 	    /*
sl@0: 	     * Execute this script. The results will be saved into
sl@0: 	     * a list object which will be retreived later. See
sl@0: 	     * ExecuteRemoteObject.
sl@0: 	     */
sl@0: 
sl@0: 	    Tcl_Obj *returnPackagePtr;
sl@0: 
sl@0: 	    for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
sl@0: 		    && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
sl@0: 		/*
sl@0: 		 * Empty loop body.
sl@0: 		 */
sl@0: 
sl@0: 	    }
sl@0: 
sl@0: 	    if (convPtr == NULL) {
sl@0: 		return (HDDEDATA) DDE_FNOTPROCESSED;
sl@0: 	    }
sl@0: 
sl@0: 	    utilString = (char *) DdeAccessData(hData, &dlen);
sl@0: 	    len = dlen;
sl@0: 	    ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
sl@0: 	    Tcl_IncrRefCount(ddeObjectPtr);
sl@0: 	    DdeUnaccessData(hData);
sl@0: 	    if (convPtr->returnPackagePtr != NULL) {
sl@0: 		Tcl_DecrRefCount(convPtr->returnPackagePtr);
sl@0: 	    }
sl@0: 	    convPtr->returnPackagePtr = NULL;
sl@0: 	    returnPackagePtr = 
sl@0: 		    ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
sl@0: 	    Tcl_IncrRefCount(returnPackagePtr);
sl@0: 	    for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
sl@0:  		    && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
sl@0: 		/*
sl@0: 		 * Empty loop body.
sl@0: 		 */
sl@0: 
sl@0: 	    }
sl@0: 	    if (convPtr != NULL) {
sl@0: 		convPtr->returnPackagePtr = returnPackagePtr;
sl@0: 	    } else {
sl@0: 		Tcl_DecrRefCount(returnPackagePtr);
sl@0: 	    }
sl@0: 	    Tcl_DecrRefCount(ddeObjectPtr);
sl@0: 	    if (returnPackagePtr == NULL) {
sl@0: 		return (HDDEDATA) DDE_FNOTPROCESSED;
sl@0: 	    } else {
sl@0: 		return (HDDEDATA) DDE_FACK;
sl@0: 	    }
sl@0: 	}
sl@0: 	    
sl@0: 	case XTYP_WILDCONNECT: {
sl@0: 
sl@0: 	    /*
sl@0: 	     * Dde wants a list of services and topics that we support.
sl@0: 	     */
sl@0: 
sl@0: 	    HSZPAIR *returnPtr;
sl@0: 	    int i;
sl@0: 	    int numItems;
sl@0: 
sl@0: 	    for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL;
sl@0: 		    i++, riPtr = riPtr->nextPtr) {
sl@0: 		/*
sl@0: 		 * Empty loop body.
sl@0: 		 */
sl@0: 
sl@0: 	    }
sl@0: 
sl@0: 	    numItems = i;
sl@0: 	    ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
sl@0: 		    (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
sl@0: 	    returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
sl@0: 	    len = dlen;
sl@0: 	    for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; 
sl@0: 		    i++, riPtr = riPtr->nextPtr) {
sl@0: 		returnPtr[i].hszSvc = DdeCreateStringHandle(
sl@0:                         ddeInstance, "TclEval", CP_WINANSI);
sl@0: 		returnPtr[i].hszTopic = DdeCreateStringHandle(
sl@0:                         ddeInstance, riPtr->name, CP_WINANSI);
sl@0: 	    }
sl@0: 	    returnPtr[i].hszSvc = NULL;
sl@0: 	    returnPtr[i].hszTopic = NULL;
sl@0: 	    DdeUnaccessData(ddeReturn);
sl@0: 	    return ddeReturn;
sl@0: 	}
sl@0: 
sl@0:     }
sl@0:     return NULL;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *--------------------------------------------------------------
sl@0:  *
sl@0:  * DdeExitProc --
sl@0:  *
sl@0:  *	Gets rid of our DDE server when we go away.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	The DDE server is deleted.
sl@0:  *
sl@0:  *--------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: DdeExitProc(
sl@0:     ClientData clientData)	    /* Not used in this handler. */
sl@0: {
sl@0:     DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
sl@0:     DdeUninitialize(ddeInstance);
sl@0:     ddeInstance = 0;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *--------------------------------------------------------------
sl@0:  *
sl@0:  * MakeDdeConnection --
sl@0:  *
sl@0:  *	This procedure is a utility used to connect to a DDE
sl@0:  *	server when given a server name and a topic name.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl result.
sl@0:  *	
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Passes back a conversation through ddeConvPtr
sl@0:  *
sl@0:  *--------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: MakeDdeConnection(
sl@0:     Tcl_Interp *interp,		/* Used to report errors. */
sl@0:     char *name,			/* The connection to use. */
sl@0:     HCONV *ddeConvPtr)
sl@0: {
sl@0:     HSZ ddeTopic, ddeService;
sl@0:     HCONV ddeConv;
sl@0:     
sl@0:     ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
sl@0:     ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
sl@0: 
sl@0:     ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
sl@0:     DdeFreeStringHandle(ddeInstance, ddeService);
sl@0:     DdeFreeStringHandle(ddeInstance, ddeTopic);
sl@0: 
sl@0:     if (ddeConv == (HCONV) NULL) {
sl@0: 	if (interp != NULL) {
sl@0: 	    Tcl_AppendResult(interp, "no registered server named \"",
sl@0: 		    name, "\"", (char *) NULL);
sl@0: 	}
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     *ddeConvPtr = ddeConv;
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *--------------------------------------------------------------
sl@0:  *
sl@0:  * DdeGetServicesList --
sl@0:  *
sl@0:  *	This procedure obtains the list of DDE services.
sl@0:  *
sl@0:  *	The functions between here and this procedure are all
sl@0:  *	involved with handling the DDE callbacks for this.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Sets the services list into the interp result.
sl@0:  *
sl@0:  *--------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: typedef struct ddeEnumServices {
sl@0:     Tcl_Interp *interp;
sl@0:     int         result;
sl@0:     ATOM        service;
sl@0:     ATOM        topic;
sl@0:     HWND        hwnd;
sl@0: } ddeEnumServices;
sl@0: 
sl@0: LRESULT CALLBACK
sl@0: DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam);
sl@0: static LRESULT
sl@0: DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam);
sl@0: 
sl@0: static int
sl@0: DdeCreateClient(ddeEnumServices *es)
sl@0: {
sl@0:     WNDCLASSEX wc;
sl@0:     static const char *szDdeClientClassName = "TclEval client class";
sl@0:     static const char *szDdeClientWindowName = "TclEval client window";
sl@0: 
sl@0:     memset(&wc, 0, sizeof(wc));
sl@0:     wc.cbSize = sizeof(wc);
sl@0:     wc.lpfnWndProc = DdeClientWindowProc;
sl@0:     wc.lpszClassName = szDdeClientClassName;
sl@0:     wc.cbWndExtra = sizeof(ddeEnumServices*);
sl@0: 
sl@0:     /* register and create the callback window */
sl@0:     RegisterClassEx(&wc);
sl@0:     es->hwnd = CreateWindowEx(0, szDdeClientClassName,
sl@0: 			      szDdeClientWindowName,
sl@0: 			      WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL,
sl@0: 			      (LPVOID)es);
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: LRESULT CALLBACK
sl@0: DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)
sl@0: {
sl@0:     LRESULT lr = 0L;
sl@0: 
sl@0:     switch (uMsg) {
sl@0: 	case WM_CREATE: {
sl@0: 	    LPCREATESTRUCT lpcs = (LPCREATESTRUCT)lParam;
sl@0: 	    ddeEnumServices *es;
sl@0: 	    es = (ddeEnumServices*)lpcs->lpCreateParams;
sl@0: #ifdef _WIN64
sl@0: 	    SetWindowLongPtr(hwnd, GWLP_USERDATA, (long)es);
sl@0: #else
sl@0: 	    SetWindowLong(hwnd, GWL_USERDATA, (long)es);
sl@0: #endif
sl@0: 	    break;
sl@0: 	}
sl@0: 	case WM_DDE_ACK:
sl@0: 	    lr =  DdeServicesOnAck(hwnd, wParam, lParam);
sl@0: 	    break;
sl@0: 	default:
sl@0: 	    lr = DefWindowProc(hwnd, uMsg, wParam, lParam);
sl@0:     }
sl@0:     return lr;
sl@0: }
sl@0: 
sl@0: static LRESULT
sl@0: DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam)
sl@0: {
sl@0:     HWND hwndRemote = (HWND)wParam;
sl@0:     ATOM service = (ATOM)LOWORD(lParam);
sl@0:     ATOM topic = (ATOM)HIWORD(lParam);
sl@0:     ddeEnumServices *es;
sl@0:     TCHAR sz[255];
sl@0: 
sl@0: #ifdef _WIN64
sl@0:     es = (ddeEnumServices *)GetWindowLongPtr(hwnd, GWLP_USERDATA);
sl@0: #else
sl@0:     es = (ddeEnumServices *)GetWindowLong(hwnd, GWL_USERDATA);
sl@0: #endif
sl@0: 
sl@0:     if ((es->service == (ATOM)NULL || es->service == service)
sl@0: 	&& (es->topic == (ATOM)NULL || es->topic == topic)) {
sl@0: 	Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
sl@0: 
sl@0: 	GlobalGetAtomName(service, sz, 255);
sl@0: 	Tcl_ListObjAppendElement(es->interp, matchPtr,
sl@0: 		Tcl_NewStringObj(sz, -1));
sl@0: 	GlobalGetAtomName(topic, sz, 255);
sl@0: 	Tcl_ListObjAppendElement(es->interp, matchPtr,
sl@0: 		Tcl_NewStringObj(sz, -1));
sl@0: 	/* Adding the hwnd as a third list element provides a unique
sl@0: 	 * identifier in the case of multiple servers with the name
sl@0: 	 * application and topic names.
sl@0: 	 */
sl@0: 	/* Needs a TIP though
sl@0: 	 * Tcl_ListObjAppendElement(es->interp, matchPtr,
sl@0: 	 *	Tcl_NewLongObj((long)hwndRemote));
sl@0: 	 */
sl@0: 	Tcl_ListObjAppendElement(es->interp,
sl@0: 		Tcl_GetObjResult(es->interp), matchPtr);
sl@0:     }
sl@0: 
sl@0:     /* tell the server we are no longer interested */
sl@0:     PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
sl@0:     return 0L;
sl@0: }
sl@0: 
sl@0: static BOOL CALLBACK
sl@0: DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam)
sl@0: {
sl@0:     LRESULT dwResult = 0;
sl@0:     ddeEnumServices *es = (ddeEnumServices *)lParam;
sl@0:     SendMessageTimeout(hwndTarget, WM_DDE_INITIATE,
sl@0: 		       (WPARAM)es->hwnd,
sl@0: 		       MAKELONG(es->service, es->topic),
sl@0: 		       SMTO_ABORTIFHUNG, 1000, &dwResult);
sl@0:     return TRUE;
sl@0: }
sl@0: 
sl@0: static int
sl@0: DdeGetServicesList(Tcl_Interp *interp, char *serviceName, char *topicName)
sl@0: {
sl@0:     ddeEnumServices es;
sl@0:     int r = TCL_OK;
sl@0:     es.interp = interp;
sl@0:     es.result = TCL_OK;
sl@0:     es.service = (serviceName == NULL) 
sl@0: 	? (ATOM)NULL : GlobalAddAtom(serviceName);
sl@0:     es.topic = (topicName == NULL) 
sl@0: 	? (ATOM)NULL : GlobalAddAtom(topicName);
sl@0:     
sl@0:     Tcl_ResetResult(interp); /* our list is to be appended to result. */
sl@0:     DdeCreateClient(&es);
sl@0:     EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es);
sl@0:     
sl@0:     if (IsWindow(es.hwnd))
sl@0:         DestroyWindow(es.hwnd);
sl@0:     if (es.service != (ATOM)NULL)
sl@0: 	GlobalDeleteAtom(es.service);
sl@0:     if (es.topic != (ATOM)NULL)
sl@0: 	GlobalDeleteAtom(es.topic);
sl@0:     return es.result;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *--------------------------------------------------------------
sl@0:  *
sl@0:  * SetDdeError --
sl@0:  *
sl@0:  *	Sets the interp result to a cogent error message
sl@0:  *	describing the last DDE error.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *	
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	The interp's result object is changed.
sl@0:  *
sl@0:  *--------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: SetDdeError(
sl@0:     Tcl_Interp *interp)	    /* The interp to put the message in.*/
sl@0: {
sl@0:     Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
sl@0:     int err;
sl@0: 
sl@0:     err = DdeGetLastError(ddeInstance);
sl@0:     switch (err) {
sl@0: 	case DMLERR_DATAACKTIMEOUT:
sl@0: 	case DMLERR_EXECACKTIMEOUT:
sl@0: 	case DMLERR_POKEACKTIMEOUT:
sl@0: 	    Tcl_SetStringObj(resultPtr,
sl@0: 		    "remote interpreter did not respond", -1);
sl@0: 	    break;
sl@0: 
sl@0: 	case DMLERR_BUSY:
sl@0: 	    Tcl_SetStringObj(resultPtr, "remote server is busy", -1);
sl@0: 	    break;
sl@0: 
sl@0: 	case DMLERR_NOTPROCESSED:
sl@0: 	    Tcl_SetStringObj(resultPtr, 
sl@0: 		    "remote server cannot handle this command", -1);
sl@0: 	    break;
sl@0: 
sl@0: 	default:
sl@0: 	    Tcl_SetStringObj(resultPtr, "dde command failed", -1);
sl@0:     }
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *--------------------------------------------------------------
sl@0:  *
sl@0:  * Tcl_DdeObjCmd --
sl@0:  *
sl@0:  *	This procedure is invoked to process the "dde" Tcl command.
sl@0:  *	See the user documentation for details on what it does.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	See the user documentation.
sl@0:  *
sl@0:  *--------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: Tcl_DdeObjCmd(
sl@0:     ClientData clientData,	/* Used only for deletion */
sl@0:     Tcl_Interp *interp,		/* The interp we are sending from */
sl@0:     int objc,			/* Number of arguments */
sl@0:     Tcl_Obj *CONST objv[])	/* The arguments */
sl@0: {
sl@0:     enum {
sl@0: 	DDE_SERVERNAME,
sl@0: 	DDE_EXECUTE,
sl@0: 	DDE_POKE,
sl@0: 	DDE_REQUEST,
sl@0: 	DDE_SERVICES,
sl@0: 	DDE_EVAL
sl@0:     };
sl@0: 
sl@0:     static CONST char *ddeCommands[] = {"servername", "execute", "poke",
sl@0:           "request", "services", "eval", 
sl@0: 	  (char *) NULL};
sl@0:     static CONST char *ddeOptions[] = {"-async", (char *) NULL};
sl@0:     static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL};
sl@0:     int index, argIndex;
sl@0:     int async = 0, binary = 0;
sl@0:     int result = TCL_OK;
sl@0:     HSZ ddeService = NULL;
sl@0:     HSZ ddeTopic = NULL;
sl@0:     HSZ ddeItem = NULL;
sl@0:     HDDEDATA ddeData = NULL;
sl@0:     HDDEDATA ddeItemData = NULL;
sl@0:     HCONV hConv = NULL;
sl@0:     HSZ ddeCookie = 0;
sl@0:     char *serviceName, *topicName, *itemString, *dataString;
sl@0:     char *string;
sl@0:     int firstArg, length, dataLength;
sl@0:     DWORD ddeResult;
sl@0:     HDDEDATA ddeReturn;
sl@0:     RegisteredInterp *riPtr;
sl@0:     Tcl_Interp *sendInterp;
sl@0:     Tcl_Obj *objPtr;
sl@0:     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0: 
sl@0:     /*
sl@0:      * Initialize DDE server/client
sl@0:      */
sl@0:     
sl@0:     if (objc < 2) {
sl@0: 	Tcl_WrongNumArgs(interp, 1, objv, 
sl@0: 		"?-async? serviceName topicName value");
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0,
sl@0: 	    &index) != TCL_OK) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     switch (index) {
sl@0: 	case DDE_SERVERNAME:
sl@0: 	    if ((objc != 3) && (objc != 2)) {
sl@0: 		Tcl_WrongNumArgs(interp, 1, objv, "servername ?serverName?");
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    firstArg = (objc - 1);
sl@0: 	    break;
sl@0: 	case DDE_EXECUTE:
sl@0: 	    if ((objc < 5) || (objc > 6)) {
sl@0: 		Tcl_WrongNumArgs(interp, 1, objv, 
sl@0: 			"execute ?-async? serviceName topicName value");
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
sl@0: 		    &argIndex) != TCL_OK) {
sl@0: 		if (objc != 5) {
sl@0: 		    Tcl_WrongNumArgs(interp, 1, objv,
sl@0: 			    "execute ?-async? serviceName topicName value");
sl@0: 		    return TCL_ERROR;
sl@0: 		}
sl@0: 		async = 0;
sl@0: 		firstArg = 2;
sl@0: 	    } else {
sl@0: 		if (objc != 6) {
sl@0: 		    Tcl_WrongNumArgs(interp, 1, objv,
sl@0: 			    "execute ?-async? serviceName topicName value");
sl@0: 		    return TCL_ERROR;
sl@0: 		}
sl@0: 		async = 1;
sl@0: 		firstArg = 3;
sl@0: 	    }
sl@0: 	    break;
sl@0:  	case DDE_POKE:
sl@0: 	    if (objc != 6) {
sl@0: 		Tcl_WrongNumArgs(interp, 1, objv,
sl@0: 			"poke serviceName topicName item value");
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    firstArg = 2;
sl@0: 	    break;
sl@0: 	case DDE_REQUEST:
sl@0: 	    if ((objc < 5) || (objc > 6)) {
sl@0: 		Tcl_WrongNumArgs(interp, 1, objv, 
sl@0: 			"request ?-binary? serviceName topicName value");
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
sl@0: 		    &argIndex) != TCL_OK) {
sl@0: 		if (objc != 5) {
sl@0: 		    Tcl_WrongNumArgs(interp, 1, objv,
sl@0: 			    "request ?-binary? serviceName topicName value");
sl@0: 		    return TCL_ERROR;
sl@0: 		}
sl@0: 		binary = 0;
sl@0: 		firstArg = 2;
sl@0: 	    } else {
sl@0: 		if (objc != 6) {
sl@0: 		    Tcl_WrongNumArgs(interp, 1, objv,
sl@0: 			    "request ?-binary? serviceName topicName value");
sl@0: 		    return TCL_ERROR;
sl@0: 		}
sl@0: 		binary = 1;
sl@0: 		firstArg = 3;
sl@0: 	    }
sl@0: 	    break;
sl@0: 	case DDE_SERVICES:
sl@0: 	    if (objc != 4) {
sl@0: 		Tcl_WrongNumArgs(interp, 1, objv,
sl@0: 			"services serviceName topicName");
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    firstArg = 2;
sl@0: 	    break;
sl@0: 	case DDE_EVAL:
sl@0: 	    if (objc < 4) {
sl@0: 		Tcl_WrongNumArgs(interp, 1, objv, 
sl@0: 			"eval ?-async? serviceName args");
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
sl@0: 		    &argIndex) != TCL_OK) {
sl@0: 		if (objc < 4) {
sl@0: 		    Tcl_WrongNumArgs(interp, 1, objv,
sl@0: 			    "eval ?-async? serviceName args");
sl@0: 		    return TCL_ERROR;
sl@0: 		}
sl@0: 		async = 0;
sl@0: 		firstArg = 2;
sl@0: 	    } else {
sl@0: 		if (objc < 5) {
sl@0: 		    Tcl_WrongNumArgs(interp, 1, objv,
sl@0: 			    "eval ?-async? serviceName args");
sl@0: 		    return TCL_ERROR;
sl@0: 		}
sl@0: 		async = 1;
sl@0: 		firstArg = 3;
sl@0: 	    }
sl@0: 	    break;
sl@0:     }
sl@0: 
sl@0:     Initialize();
sl@0: 
sl@0:     if (firstArg != 1) {
sl@0: 	serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
sl@0:     } else {
sl@0: 	length = 0;
sl@0:     }
sl@0: 
sl@0:     if (length == 0) {
sl@0: 	serviceName = NULL;
sl@0:     } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
sl@0: 	ddeService = DdeCreateStringHandle(ddeInstance, serviceName,
sl@0: 		CP_WINANSI);
sl@0:     }
sl@0: 
sl@0:     if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) {
sl@0: 	topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
sl@0: 	if (length == 0) {
sl@0: 	    topicName = NULL;
sl@0: 	} else {
sl@0: 	    ddeTopic = DdeCreateStringHandle(ddeInstance, 
sl@0: 		    topicName, CP_WINANSI);
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     switch (index) {
sl@0: 	case DDE_SERVERNAME: {
sl@0: 	    serviceName = DdeSetServerName(interp, serviceName);
sl@0: 	    if (serviceName != NULL) {
sl@0: 		Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0: 			serviceName, -1);
sl@0: 	    } else {
sl@0: 		Tcl_ResetResult(interp);
sl@0: 	    }
sl@0: 	    break;
sl@0: 	}
sl@0: 	case DDE_EXECUTE: {
sl@0: 	    dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
sl@0: 	    if (dataLength == 0) {
sl@0: 		Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0: 			"cannot execute null data", -1);
sl@0: 		result = TCL_ERROR;
sl@0: 		break;
sl@0: 	    }
sl@0: 	    hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
sl@0: 	    DdeFreeStringHandle(ddeInstance, ddeService);
sl@0: 	    DdeFreeStringHandle(ddeInstance, ddeTopic);
sl@0: 
sl@0: 	    if (hConv == NULL) {
sl@0: 		SetDdeError(interp);
sl@0: 		result = TCL_ERROR;
sl@0: 		break;
sl@0: 	    }
sl@0: 
sl@0: 	    ddeData = DdeCreateDataHandle(ddeInstance, dataString,
sl@0: 		    (DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
sl@0: 	    if (ddeData != NULL) {
sl@0: 		if (async) {
sl@0: 		    DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, 
sl@0: 			    CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
sl@0: 		    DdeAbandonTransaction(ddeInstance, hConv, 
sl@0: 			    ddeResult);
sl@0: 		} else {
sl@0: 		    ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
sl@0: 			    hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
sl@0: 		    if (ddeReturn == 0) {
sl@0: 			SetDdeError(interp);
sl@0: 			result = TCL_ERROR;
sl@0: 		    }
sl@0: 		}
sl@0: 		DdeFreeDataHandle(ddeData);
sl@0: 	    } else {
sl@0: 		SetDdeError(interp);
sl@0: 		result = TCL_ERROR;
sl@0: 	    }
sl@0: 	    break;
sl@0: 	}
sl@0: 	case DDE_REQUEST: {
sl@0: 	    itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
sl@0: 	    if (length == 0) {
sl@0: 		Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0: 			"cannot request value of null data", -1);
sl@0: 		goto errorNoResult;
sl@0: 	    }
sl@0: 	    hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
sl@0: 	    DdeFreeStringHandle(ddeInstance, ddeService);
sl@0: 	    DdeFreeStringHandle(ddeInstance, ddeTopic);
sl@0: 	    
sl@0: 	    if (hConv == NULL) {
sl@0: 		SetDdeError(interp);
sl@0: 		result = TCL_ERROR;
sl@0: 	    } else {
sl@0: 		Tcl_Obj *returnObjPtr;
sl@0: 		ddeItem = DdeCreateStringHandle(ddeInstance, 
sl@0:                         itemString, CP_WINANSI);
sl@0: 		if (ddeItem != NULL) {
sl@0: 		    ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
sl@0: 			    CF_TEXT, XTYP_REQUEST, 5000, NULL);
sl@0: 		    if (ddeData == NULL) {
sl@0: 			SetDdeError(interp);
sl@0: 			result = TCL_ERROR;
sl@0: 		    } else {
sl@0: 			DWORD tmp;
sl@0: 			dataString = DdeAccessData(ddeData, &tmp);
sl@0: 			dataLength = tmp;
sl@0: 			if (binary) {
sl@0: 			    returnObjPtr = Tcl_NewByteArrayObj(dataString,
sl@0: 				    dataLength);
sl@0: 			} else {
sl@0: 			    returnObjPtr = Tcl_NewStringObj(dataString, -1);
sl@0: 			}
sl@0: 			DdeUnaccessData(ddeData);
sl@0: 			DdeFreeDataHandle(ddeData);
sl@0: 			Tcl_SetObjResult(interp, returnObjPtr);
sl@0: 		    }
sl@0: 		} else {
sl@0: 		    SetDdeError(interp);
sl@0: 		    result = TCL_ERROR;
sl@0: 		}
sl@0: 	    }
sl@0: 
sl@0: 	    break;
sl@0: 	}
sl@0: 	case DDE_POKE: {
sl@0: 	    itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
sl@0: 	    if (length == 0) {
sl@0: 		Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0: 			"cannot have a null item", -1);
sl@0: 		goto errorNoResult;
sl@0: 	    }
sl@0: 	    dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
sl@0: 	    
sl@0: 	    hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
sl@0: 	    DdeFreeStringHandle(ddeInstance, ddeService);
sl@0: 	    DdeFreeStringHandle(ddeInstance, ddeTopic);
sl@0: 
sl@0: 	    if (hConv == NULL) {
sl@0: 		SetDdeError(interp);
sl@0: 		result = TCL_ERROR;
sl@0: 	    } else {
sl@0: 		ddeItem = DdeCreateStringHandle(ddeInstance, itemString,
sl@0: 			CP_WINANSI);
sl@0: 		if (ddeItem != NULL) {
sl@0: 		    ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
sl@0: 			    hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
sl@0: 		    if (ddeData == NULL) {
sl@0: 			SetDdeError(interp);
sl@0: 			result = TCL_ERROR;
sl@0: 		    }
sl@0: 		} else {
sl@0: 		    SetDdeError(interp);
sl@0: 		    result = TCL_ERROR;
sl@0: 		}
sl@0: 	    }
sl@0: 	    break;
sl@0: 	}
sl@0: 
sl@0: 	case DDE_SERVICES: {
sl@0: 	    result = DdeGetServicesList(interp, serviceName, topicName);
sl@0: 	    break;
sl@0: 	}
sl@0: 	case DDE_EVAL: {
sl@0: 	    if (serviceName == NULL) {
sl@0: 		Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0: 			"invalid service name \"\"", -1);
sl@0: 		goto errorNoResult;
sl@0: 	    }
sl@0: 
sl@0: 	    objc -= (async + 3);
sl@0: 	    ((Tcl_Obj **) objv) += (async + 3);
sl@0: 
sl@0:             /*
sl@0: 	     * See if the target interpreter is local.  If so, execute
sl@0: 	     * the command directly without going through the DDE server.
sl@0: 	     * Don't exchange objects between interps.  The target interp could
sl@0: 	     * compile an object, producing a bytecode structure that refers to 
sl@0: 	     * other objects owned by the target interp.  If the target interp 
sl@0: 	     * is then deleted, the bytecode structure would be referring to 
sl@0: 	     * deallocated objects.
sl@0: 	     */
sl@0: 	    
sl@0: 	    for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
sl@0: 		 riPtr = riPtr->nextPtr) {
sl@0: 		if (stricmp(serviceName, riPtr->name) == 0) {
sl@0: 		    break;
sl@0: 		}
sl@0: 	    }
sl@0: 
sl@0: 	    if (riPtr != NULL) {
sl@0: 		/*
sl@0: 		 * This command is to a local interp. No need to go through
sl@0: 		 * the server.
sl@0: 		 */
sl@0: 		
sl@0: 		Tcl_Preserve((ClientData) riPtr);
sl@0: 		sendInterp = riPtr->interp;
sl@0: 		Tcl_Preserve((ClientData) sendInterp);
sl@0: 		
sl@0: 		/*
sl@0: 		 * Don't exchange objects between interps.  The target interp
sl@0: 		 * would compile an object, producing a bytecode structure that
sl@0: 		 * refers to other objects owned by the target interp.  If the
sl@0: 		 * target interp is then deleted, the bytecode structure would
sl@0: 		 * be referring to deallocated objects.
sl@0: 		 */
sl@0: 
sl@0: 		if (objc == 1) {
sl@0: 		    result = Tcl_EvalObjEx(sendInterp, objv[0],
sl@0: 			    TCL_EVAL_GLOBAL);
sl@0: 		} else {
sl@0: 		    objPtr = Tcl_ConcatObj(objc, objv);
sl@0: 		    Tcl_IncrRefCount(objPtr);
sl@0: 		    result = Tcl_EvalObjEx(sendInterp, objPtr,
sl@0: 			    TCL_EVAL_GLOBAL);
sl@0: 		    Tcl_DecrRefCount(objPtr);
sl@0: 		}
sl@0: 		if (interp != sendInterp) {
sl@0: 		    if (result == TCL_ERROR) {
sl@0: 			/*
sl@0: 			 * An error occurred, so transfer error information
sl@0: 			 * from the destination interpreter back to our
sl@0: 			 * interpreter.
sl@0: 			 */
sl@0: 			
sl@0: 			Tcl_ResetResult(interp);
sl@0: 			objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, 
sl@0: 				TCL_GLOBAL_ONLY);
sl@0: 			string = Tcl_GetStringFromObj(objPtr, &length);
sl@0: 			Tcl_AddObjErrorInfo(interp, string, length);
sl@0: 			
sl@0: 			objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
sl@0: 				TCL_GLOBAL_ONLY);
sl@0: 			Tcl_SetObjErrorCode(interp, objPtr);
sl@0: 		    }
sl@0: 		    Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
sl@0: 		}
sl@0: 		Tcl_Release((ClientData) riPtr);
sl@0: 		Tcl_Release((ClientData) sendInterp);
sl@0: 	    } else {
sl@0: 		/*
sl@0: 		 * This is a non-local request. Send the script to the server
sl@0: 		 * and poll it for a result.
sl@0: 		 */
sl@0: 		
sl@0: 		if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
sl@0: 		    goto error;
sl@0: 		}
sl@0: 		
sl@0: 		objPtr = Tcl_ConcatObj(objc, objv);
sl@0: 		string = Tcl_GetStringFromObj(objPtr, &length);
sl@0: 		ddeItemData = DdeCreateDataHandle(ddeInstance, string,
sl@0: 			(DWORD) length+1, 0, 0, CF_TEXT, 0);
sl@0: 		
sl@0: 		if (async) {
sl@0: 		    ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
sl@0: 			    0xFFFFFFFF, hConv, 0,
sl@0: 			    CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
sl@0: 		    DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
sl@0: 		} else {
sl@0: 		    ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
sl@0: 			    0xFFFFFFFF, hConv, 0,
sl@0: 			    CF_TEXT, XTYP_EXECUTE, 30000, NULL);
sl@0: 		    if (ddeData != 0) {
sl@0: 			
sl@0: 			ddeCookie = DdeCreateStringHandle(ddeInstance, 
sl@0: 				"$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
sl@0: 			ddeData = DdeClientTransaction(NULL, 0, hConv,
sl@0: 				ddeCookie, CF_TEXT, XTYP_REQUEST, 30000, NULL);
sl@0: 		    }
sl@0: 		}
sl@0: 
sl@0: 		Tcl_DecrRefCount(objPtr);
sl@0: 		
sl@0: 		if (ddeData == 0) {
sl@0: 		    SetDdeError(interp);
sl@0: 		    goto errorNoResult;
sl@0: 		}
sl@0: 		
sl@0: 		if (async == 0) {
sl@0: 		    Tcl_Obj *resultPtr;
sl@0: 		    
sl@0: 		    /*
sl@0: 		     * The return handle has a two or four element list in
sl@0: 		     * it. The first element is the return code (TCL_OK,
sl@0: 		     * TCL_ERROR, etc.). The second is the result of the
sl@0: 		     * script. If the return code is TCL_ERROR, then the third
sl@0: 		     * element is the value of the variable "errorCode", and
sl@0: 		     * the fourth is the value of the variable "errorInfo".
sl@0: 		     */
sl@0: 		    
sl@0: 		    resultPtr = Tcl_NewObj();
sl@0: 		    length = DdeGetData(ddeData, NULL, 0, 0);
sl@0: 		    Tcl_SetObjLength(resultPtr, length);
sl@0: 		    string = Tcl_GetString(resultPtr);
sl@0: 		    DdeGetData(ddeData, string, (DWORD) length, 0);
sl@0: 		    Tcl_SetObjLength(resultPtr, (int) strlen(string));
sl@0: 		    
sl@0: 		    if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr)
sl@0: 			    != TCL_OK) {
sl@0: 			Tcl_DecrRefCount(resultPtr);
sl@0: 			goto error;
sl@0: 		    }
sl@0: 		    if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
sl@0: 			Tcl_DecrRefCount(resultPtr);
sl@0: 			goto error;
sl@0: 		    }
sl@0: 		    if (result == TCL_ERROR) {
sl@0: 			Tcl_ResetResult(interp);
sl@0: 
sl@0: 			if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr)
sl@0: 				!= TCL_OK) {
sl@0: 			    Tcl_DecrRefCount(resultPtr);
sl@0: 			    goto error;
sl@0: 			}
sl@0: 			length = -1;
sl@0: 			string = Tcl_GetStringFromObj(objPtr, &length);
sl@0: 			Tcl_AddObjErrorInfo(interp, string, length);
sl@0: 			
sl@0: 			Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
sl@0: 			Tcl_SetObjErrorCode(interp, objPtr);
sl@0: 		    }
sl@0: 		    if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr)
sl@0: 			    != TCL_OK) {
sl@0: 			Tcl_DecrRefCount(resultPtr);
sl@0: 			goto error;
sl@0: 		    }
sl@0: 		    Tcl_SetObjResult(interp, objPtr);
sl@0: 		    Tcl_DecrRefCount(resultPtr);
sl@0: 		}
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     if (ddeCookie != NULL) {
sl@0: 	DdeFreeStringHandle(ddeInstance, ddeCookie);
sl@0:     }
sl@0:     if (ddeItem != NULL) {
sl@0: 	DdeFreeStringHandle(ddeInstance, ddeItem);
sl@0:     }
sl@0:     if (ddeItemData != NULL) {
sl@0: 	DdeFreeDataHandle(ddeItemData);
sl@0:     }
sl@0:     if (ddeData != NULL) {
sl@0: 	DdeFreeDataHandle(ddeData);
sl@0:     }
sl@0:     if (hConv != NULL) {
sl@0: 	DdeDisconnect(hConv);
sl@0:     }
sl@0:     return result;
sl@0: 
sl@0:     error:
sl@0:     Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0: 	    "invalid data returned from server", -1);
sl@0: 
sl@0:     errorNoResult:
sl@0:     if (ddeCookie != NULL) {
sl@0: 	DdeFreeStringHandle(ddeInstance, ddeCookie);
sl@0:     }
sl@0:     if (ddeItem != NULL) {
sl@0: 	DdeFreeStringHandle(ddeInstance, ddeItem);
sl@0:     }
sl@0:     if (ddeItemData != NULL) {
sl@0: 	DdeFreeDataHandle(ddeItemData);
sl@0:     }
sl@0:     if (ddeData != NULL) {
sl@0: 	DdeFreeDataHandle(ddeData);
sl@0:     }
sl@0:     if (hConv != NULL) {
sl@0: 	DdeDisconnect(hConv);
sl@0:     }
sl@0:     return TCL_ERROR;
sl@0: }