开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tclWinDde.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：40k
源码类别：

通讯编程

开发平台：

Visual C++

tclWinDde.c：源码内容
  1. /* 
  2.  * tclWinDde.c --
  3.  *
  4.  * This file provides procedures that implement the "send"
  5.  * command, allowing commands to be passed from interpreter
  6.  * to interpreter.
  7.  *
  8.  * Copyright (c) 1997 by Sun Microsystems, Inc.
  9.  *
  10.  * See the file "license.terms" for information on usage and redistribution
  11.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  *
  13.  * RCS: @(#) $Id: tclWinDde.c,v 1.13.2.7 2006/04/05 20:50:46 dgp Exp $
  14.  */
  16. #include "tclPort.h"
  17. #include <dde.h>
  18. #include <ddeml.h>
  19. #include <tchar.h>
  21. /*
  22.  * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
  23.  * Registry_Init declaration is in the source file itself, which is only
  24.  * accessed when we are building a library.
  25.  */
  27. #undef TCL_STORAGE_CLASS
  28. #define TCL_STORAGE_CLASS DLLEXPORT
  30. /* 
  31.  * The following structure is used to keep track of the interpreters
  32.  * registered by this process.
  33.  */
  35. typedef struct RegisteredInterp {
  36.     struct RegisteredInterp *nextPtr;
  37. /* The next interp this application knows
  38.  * about. */
  39.     char *name; /* Interpreter's name (malloc-ed). */
  40.     Tcl_Interp *interp; /* The interpreter attached to this name. */
  41. } RegisteredInterp;
  43. /*
  44.  * Used to keep track of conversations.
  45.  */
  47. typedef struct Conversation {
  48.     struct Conversation *nextPtr;
  49. /* The next conversation in the list. */
  50.     RegisteredInterp *riPtr; /* The info we know about the conversation. */
  51.     HCONV hConv; /* The DDE handle for this conversation. */
  52.     Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
  53. } Conversation;
  55. typedef struct ThreadSpecificData {
  56.     Conversation *currentConversations;
  57.                                 /* A list of conversations currently
  58.  * being processed. */
  59.     RegisteredInterp *interpListPtr;
  60.                                 /* List of all interpreters registered
  61.  * in the current process. */
  62. } ThreadSpecificData;
  63. static Tcl_ThreadDataKey dataKey;
  65. /*
  66.  * The following variables cannot be placed in thread-local storage.
  67.  * The Mutex ddeMutex guards access to the ddeInstance.
  68.  */
  69. static HSZ ddeServiceGlobal = 0;
  70. static DWORD ddeInstance;       /* The application instance handle given
  71.  * to us by DdeInitialize. */
  72. static int ddeIsServer = 0;
  74. #define TCL_DDE_VERSION "1.2.4"
  75. #define TCL_DDE_PACKAGE_NAME "dde"
  76. #define TCL_DDE_SERVICE_NAME "TclEval"
  78. TCL_DECLARE_MUTEX(ddeMutex)
  80. /*
  81.  * Forward declarations for procedures defined later in this file.
  82.  */
  84. static void     DdeExitProc _ANSI_ARGS_((ClientData clientData));
  85. static void     DeleteProc _ANSI_ARGS_((ClientData clientData));
  86. static Tcl_Obj *     ExecuteRemoteObject _ANSI_ARGS_((
  87. RegisteredInterp *riPtr, 
  88. Tcl_Obj *ddeObjectPtr));
  89. static int     MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp,
  90. char *name, HCONV *ddeConvPtr));
  91. static HDDEDATA CALLBACK    DdeServerProc _ANSI_ARGS_((UINT uType,
  92. UINT uFmt, HCONV hConv, HSZ ddeTopic,
  93. HSZ ddeItem, HDDEDATA hData, DWORD dwData1, 
  94. DWORD dwData2));
  95. static void     SetDdeError _ANSI_ARGS_((Tcl_Interp *interp));
  96. static int                  DdeGetServicesList _ANSI_ARGS_((
  97. Tcl_Interp *interp,
  98. char *serviceName,
  99. char *topicName));
  100. int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */
  101. Tcl_Interp *interp, /* The interp we are sending from */
  102. int objc, /* Number of arguments */
  103. Tcl_Obj *CONST objv[]); /* The arguments */
  105. EXTERN int Dde_Init(Tcl_Interp *interp);
  107. /*
  108.  *----------------------------------------------------------------------
  109.  *
  110.  * Dde_Init --
  111.  *
  112.  * This procedure initializes the dde command.
  113.  *
  114.  * Results:
  115.  * A standard Tcl result.
  116.  *
  117.  * Side effects:
  118.  * None.
  119.  *
  120.  *----------------------------------------------------------------------
  121.  */
  123. int
  124. Dde_Init(
  125.     Tcl_Interp *interp)
  126. {
  127.     ThreadSpecificData *tsdPtr;
  129.     if (!Tcl_InitStubs(interp, "8.0", 0)) {
  130. return TCL_ERROR;
  131.     }
  133.     Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL);
  135.     tsdPtr = TCL_TSD_INIT(&dataKey);
  137.     Tcl_CreateExitHandler(DdeExitProc, NULL);
  139.     return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
  140. }
  142. /*
  143.  *----------------------------------------------------------------------
  144.  *
  145.  * Initialize --
  146.  *
  147.  * Initialize the global DDE instance.
  148.  *
  149.  * Results:
  150.  * None.
  151.  *
  152.  * Side effects:
  153.  * Registers the DDE server proc.
  154.  *
  155.  *----------------------------------------------------------------------
  156.  */
  158. static void
  159. Initialize(void)
  160. {
  161.     int nameFound = 0;
  162.     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
  163.     
  164.     /*
  165.      * See if the application is already registered; if so, remove its
  166.      * current name from the registry. The deletion of the command
  167.      * will take care of disposing of this entry.
  168.      */
  170.     if (tsdPtr->interpListPtr != NULL) {
  171. nameFound = 1;
  172.     }
  174.     /*
  175.      * Make sure that the DDE server is there. This is done only once,
  176.      * add an exit handler tear it down.
  177.      */
  179.     if (ddeInstance == 0) {
  180. Tcl_MutexLock(&ddeMutex);
  181. if (ddeInstance == 0) {
  182.     if (DdeInitialize(&ddeInstance, DdeServerProc,
  183.     CBF_SKIP_REGISTRATIONS
  184.     | CBF_SKIP_UNREGISTRATIONS
  185.     | CBF_FAIL_POKES, 0) 
  186.     != DMLERR_NO_ERROR) {
  187. ddeInstance = 0;
  188.     }
  189. }
  190. Tcl_MutexUnlock(&ddeMutex);
  191.     }
  192.     if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
  193. Tcl_MutexLock(&ddeMutex);
  194. if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
  195.     ddeIsServer = 1;
  196.     Tcl_CreateExitHandler(DdeExitProc, NULL);
  197.     ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, 
  198.     TCL_DDE_SERVICE_NAME, 0);
  199.     DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
  200. } else {
  201.     ddeIsServer = 0;
  202. }
  203. Tcl_MutexUnlock(&ddeMutex);
  204.     }
  205. }    
  207. /*
  208.  *--------------------------------------------------------------
  209.  *
  210.  * DdeSetServerName --
  211.  *
  212.  * This procedure is called to associate an ASCII name with a Dde
  213.  * server.  If the interpreter has already been named, the
  214.  * name replaces the old one.
  215.  *
  216.  * Results:
  217.  * The return value is the name actually given to the interp.
  218.  * This will normally be the same as name, but if name was already
  219.  * in use for a Dde Server then a name of the form "name #2" will
  220.  * be chosen,  with a high enough number to make the name unique.
  221.  *
  222.  * Side effects:
  223.  * Registration info is saved, thereby allowing the "send" command
  224.  * to be used later to invoke commands in the application.  In
  225.  * addition, the "send" command is created in the application's
  226.  * interpreter.  The registration will be removed automatically
  227.  * if the interpreter is deleted or the "send" command is removed.
  228.  *
  229.  *--------------------------------------------------------------
  230.  */
  232. static char *
  233. DdeSetServerName(
  234.     Tcl_Interp *interp,
  235.     char *name /* The name that will be used to
  236.  * refer to the interpreter in later
  237.  * "send" commands.  Must be globally
  238.  * unique. */
  239.     )
  240. {
  241.     int suffix, offset;
  242.     RegisteredInterp *riPtr, *prevPtr;
  243.     Tcl_DString dString;
  244.     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
  246.     /*
  247.      * See if the application is already registered; if so, remove its
  248.      * current name from the registry. The deletion of the command
  249.      * will take care of disposing of this entry.
  250.      */
  252.     for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL; 
  253.     prevPtr = riPtr, riPtr = riPtr->nextPtr) {
  254. if (riPtr->interp == interp) {
  255.     if (name != NULL) {
  256. if (prevPtr == NULL) {
  257.     tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
  258. } else {
  259.     prevPtr->nextPtr = riPtr->nextPtr;
  260. }
  261. break;
  262.     } else {
  263. /*
  264.  * the name was NULL, so the caller is asking for
  265.  * the name of the current interp.
  266.  */
  268. return riPtr->name;
  269.     }
  270. }
  271.     }
  273.     if (name == NULL) {
  274. /*
  275.  * the name was NULL, so the caller is asking for
  276.  * the name of the current interp, but it doesn't
  277.  * have a name.
  278.  */
  280. return "";
  281.     }
  282.     
  283.     /*
  284.      * Pick a name to use for the application.  Use "name" if it's not
  285.      * already in use.  Otherwise add a suffix such as " #2", trying
  286.      * larger and larger numbers until we eventually find one that is
  287.      * unique.
  288.      */
  290.     suffix = 1;
  291.     offset = 0;
  292.     Tcl_DStringInit(&dString);
  294.     /*
  295.      * We have found a unique name. Now add it to the registry.
  296.      */
  298.     riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
  299.     riPtr->interp = interp;
  300.     riPtr->name = ckalloc((unsigned int) strlen(name) + 1);
  301.     riPtr->nextPtr = tsdPtr->interpListPtr;
  302.     tsdPtr->interpListPtr = riPtr;
  303.     strcpy(riPtr->name, name);
  305.     Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
  306.     (ClientData) riPtr, DeleteProc);
  307.     if (Tcl_IsSafe(interp)) {
  308. Tcl_HideCommand(interp, "dde", "dde");
  309.     }
  310.     Tcl_DStringFree(&dString);
  312.     /*
  313.      * re-initialize with the new name
  314.      */
  315.     Initialize();
  316.     
  317.     return riPtr->name;
  318. }
  320. /*
  321.  *--------------------------------------------------------------
  322.  *
  323.  * DeleteProc
  324.  *
  325.  * This procedure is called when the command "dde" is destroyed.
  326.  *
  327.  * Results:
  328.  * none
  329.  *
  330.  * Side effects:
  331.  * The interpreter given by riPtr is unregistered.
  332.  *
  333.  *--------------------------------------------------------------
  334.  */
  336. static void
  337. DeleteProc(clientData)
  338.     ClientData clientData; /* The interp we are deleting passed
  339.  * as ClientData. */
  340. {
  341.     RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
  342.     RegisteredInterp *searchPtr, *prevPtr;
  343.     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
  345.     for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
  346.     (searchPtr != NULL) && (searchPtr != riPtr);
  347.     prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
  348. /*
  349.  * Empty loop body.
  350.  */
  351.     }
  353.     if (searchPtr != NULL) {
  354. if (prevPtr == NULL) {
  355.     tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
  356. } else {
  357.     prevPtr->nextPtr = searchPtr->nextPtr;
  358. }
  359.     }
  360.     ckfree(riPtr->name);
  361.     Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
  362. }
  364. /*
  365.  *--------------------------------------------------------------
  366.  *
  367.  * ExecuteRemoteObject --
  368.  *
  369.  * Takes the package delivered by DDE and executes it in
  370.  * the server's interpreter.
  371.  *
  372.  * Results:
  373.  * A list Tcl_Obj * that describes what happened. The first
  374.  * element is the numerical return code (TCL_ERROR, etc.).
  375.  * The second element is the result of the script. If the
  376.  * return result was TCL_ERROR, then the third element
  377.  * will be the value of the global "errorCode", and the
  378.  * fourth will be the value of the global "errorInfo".
  379.  * The return result will have a refCount of 0.
  380.  *
  381.  * Side effects:
  382.  * A Tcl script is run, which can cause all kinds of other
  383.  * things to happen.
  384.  *
  385.  *--------------------------------------------------------------
  386.  */
  388. static Tcl_Obj *
  389. ExecuteRemoteObject(
  390.     RegisteredInterp *riPtr,     /* Info about this server. */
  391.     Tcl_Obj *ddeObjectPtr)     /* The object to execute. */
  392. {
  393.     Tcl_Obj *errorObjPtr;
  394.     Tcl_Obj *returnPackagePtr;
  395.     int result;
  397.     result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
  398.     returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  399.     Tcl_ListObjAppendElement(NULL, returnPackagePtr,
  400.     Tcl_NewIntObj(result));
  401.     Tcl_ListObjAppendElement(NULL, returnPackagePtr,
  402.     Tcl_GetObjResult(riPtr->interp));
  403.     if (result == TCL_ERROR) {
  404. errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
  405. TCL_GLOBAL_ONLY);
  406. Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
  407. errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
  408. TCL_GLOBAL_ONLY);
  409.         Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
  410.     }
  412.     return returnPackagePtr;
  413. }
  415. /*
  416.  *--------------------------------------------------------------
  417.  *
  418.  * DdeServerProc --
  419.  *
  420.  * Handles all transactions for this server. Can handle
  421.  * execute, request, and connect protocols. Dde will
  422.  * call this routine when a client attempts to run a dde
  423.  * command using this server.
  424.  *
  425.  * Results:
  426.  * A DDE Handle with the result of the dde command.
  427.  *
  428.  * Side effects:
  429.  * Depending on which command is executed, arbitrary
  430.  * Tcl scripts can be run.
  431.  *
  432.  *--------------------------------------------------------------
  433.  */
  435. static HDDEDATA CALLBACK
  436. DdeServerProc (
  437.     UINT uType, /* The type of DDE transaction we
  438.  * are performing. */
  439.     UINT uFmt, /* The format that data is sent or
  440.  * received. */
  441.     HCONV hConv, /* The conversation associated with the 
  442.  * current transaction. */
  443.     HSZ ddeTopic, /* A string handle. Transaction-type 
  444.  * dependent. */
  445.     HSZ ddeItem, /* A string handle. Transaction-type 
  446.  * dependent. */
  447.     HDDEDATA hData, /* DDE data. Transaction-type dependent. */
  448.     DWORD dwData1, /* Transaction-dependent data. */
  449.     DWORD dwData2) /* Transaction-dependent data. */
  450. {
  451.     Tcl_DString dString;
  452.     int len;
  453.     DWORD dlen;
  454.     char *utilString;
  455.     Tcl_Obj *ddeObjectPtr;
  456.     HDDEDATA ddeReturn = NULL;
  457.     RegisteredInterp *riPtr;
  458.     Conversation *convPtr, *prevConvPtr;
  459.     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
  461.     switch(uType) {
  462. case XTYP_CONNECT:
  464.     /*
  465.      * Dde is trying to initialize a conversation with us. Check
  466.      * and make sure we have a valid topic.
  467.      */
  469.     len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
  470.     Tcl_DStringInit(&dString);
  471.     Tcl_DStringSetLength(&dString, len);
  472.     utilString = Tcl_DStringValue(&dString);
  473.     DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
  474.     CP_WINANSI);
  476.     for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
  477.     riPtr = riPtr->nextPtr) {
  478. if (stricmp(utilString, riPtr->name) == 0) {
  479.     Tcl_DStringFree(&dString);
  480.     return (HDDEDATA) TRUE;
  481. }
  482.     }
  484.     Tcl_DStringFree(&dString);
  485.     return (HDDEDATA) FALSE;
  487. case XTYP_CONNECT_CONFIRM:
  489.     /*
  490.      * Dde has decided that we can connect, so it gives us a 
  491.      * conversation handle. We need to keep track of it
  492.      * so we know which execution result to return in an
  493.      * XTYP_REQUEST.
  494.      */
  496.     len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
  497.     Tcl_DStringInit(&dString);
  498.     Tcl_DStringSetLength(&dString, len);
  499.     utilString = Tcl_DStringValue(&dString);
  500.     DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, 
  501.     CP_WINANSI);
  502.     for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; 
  503.     riPtr = riPtr->nextPtr) {
  504. if (stricmp(riPtr->name, utilString) == 0) {
  505.     convPtr = (Conversation *) ckalloc(sizeof(Conversation));
  506.     convPtr->nextPtr = tsdPtr->currentConversations;
  507.     convPtr->returnPackagePtr = NULL;
  508.     convPtr->hConv = hConv;
  509.     convPtr->riPtr = riPtr;
  510.     tsdPtr->currentConversations = convPtr;
  511.     break;
  512. }
  513.     }
  514.     Tcl_DStringFree(&dString);
  515.     return (HDDEDATA) TRUE;
  517. case XTYP_DISCONNECT:
  519.     /*
  520.      * The client has disconnected from our server. Forget this
  521.      * conversation.
  522.      */
  524.     for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
  525.     convPtr != NULL; 
  526.     prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
  527. if (hConv == convPtr->hConv) {
  528.     if (prevConvPtr == NULL) {
  529. tsdPtr->currentConversations = convPtr->nextPtr;
  530.     } else {
  531. prevConvPtr->nextPtr = convPtr->nextPtr;
  532.     }
  533.     if (convPtr->returnPackagePtr != NULL) {
  534. Tcl_DecrRefCount(convPtr->returnPackagePtr);
  535.     }
  536.     ckfree((char *) convPtr);
  537.     break;
  538. }
  539.     }
  540.     return (HDDEDATA) TRUE;
  542. case XTYP_REQUEST:
  544.     /*
  545.      * This could be either a request for a value of a Tcl variable,
  546.      * or it could be the send command requesting the results of the
  547.      * last execute.
  548.      */
  550.     if (uFmt != CF_TEXT) {
  551. return (HDDEDATA) FALSE;
  552.     }
  554.     ddeReturn = (HDDEDATA) FALSE;
  555.     for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
  556.     && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
  557. /*
  558.  * Empty loop body.
  559.  */
  560.     }
  562.     if (convPtr != NULL) {
  563. char *returnString;
  565. len = DdeQueryString(ddeInstance, ddeItem, NULL, 0,
  566. CP_WINANSI);
  567. Tcl_DStringInit(&dString);
  568. Tcl_DStringSetLength(&dString, len);
  569. utilString = Tcl_DStringValue(&dString);
  570. DdeQueryString(ddeInstance, ddeItem, utilString, 
  571.                         (DWORD) len + 1, CP_WINANSI);
  572. if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) {
  573.     returnString =
  574.         Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
  575.     ddeReturn = DdeCreateDataHandle(ddeInstance,
  576.     returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT,
  577.     0);
  578. } else {
  579.     Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
  580.     convPtr->riPtr->interp, utilString, NULL, 
  581.     TCL_GLOBAL_ONLY);
  582.     if (variableObjPtr != NULL) {
  583. returnString = Tcl_GetStringFromObj(variableObjPtr,
  584. &len);
  585. ddeReturn = DdeCreateDataHandle(ddeInstance,
  586. returnString, (DWORD) len+1, 0, ddeItem,
  587. CF_TEXT, 0);
  588.     } else {
  589. ddeReturn = NULL;
  590.     }
  591. }
  592. Tcl_DStringFree(&dString);
  593.     }
  594.     return ddeReturn;
  596. case XTYP_EXECUTE: {
  598.     /*
  599.      * Execute this script. The results will be saved into
  600.      * a list object which will be retreived later. See
  601.      * ExecuteRemoteObject.
  602.      */
  604.     Tcl_Obj *returnPackagePtr;
  606.     for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
  607.     && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
  608. /*
  609.  * Empty loop body.
  610.  */
  612.     }
  614.     if (convPtr == NULL) {
  615. return (HDDEDATA) DDE_FNOTPROCESSED;
  616.     }
  618.     utilString = (char *) DdeAccessData(hData, &dlen);
  619.     len = dlen;
  620.     ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
  621.     Tcl_IncrRefCount(ddeObjectPtr);
  622.     DdeUnaccessData(hData);
  623.     if (convPtr->returnPackagePtr != NULL) {
  624. Tcl_DecrRefCount(convPtr->returnPackagePtr);
  625.     }
  626.     convPtr->returnPackagePtr = NULL;
  627.     returnPackagePtr = 
  628.     ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
  629.     Tcl_IncrRefCount(returnPackagePtr);
  630.     for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
  631.       && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
  632. /*
  633.  * Empty loop body.
  634.  */
  636.     }
  637.     if (convPtr != NULL) {
  638. convPtr->returnPackagePtr = returnPackagePtr;
  639.     } else {
  640. Tcl_DecrRefCount(returnPackagePtr);
  641.     }
  642.     Tcl_DecrRefCount(ddeObjectPtr);
  643.     if (returnPackagePtr == NULL) {
  644. return (HDDEDATA) DDE_FNOTPROCESSED;
  645.     } else {
  646. return (HDDEDATA) DDE_FACK;
  647.     }
  648. }
  649.     
  650. case XTYP_WILDCONNECT: {
  652.     /*
  653.      * Dde wants a list of services and topics that we support.
  654.      */
  656.     HSZPAIR *returnPtr;
  657.     int i;
  658.     int numItems;
  660.     for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL;
  661.     i++, riPtr = riPtr->nextPtr) {
  662. /*
  663.  * Empty loop body.
  664.  */
  666.     }
  668.     numItems = i;
  669.     ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
  670.     (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
  671.     returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
  672.     len = dlen;
  673.     for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; 
  674.     i++, riPtr = riPtr->nextPtr) {
  675. returnPtr[i].hszSvc = DdeCreateStringHandle(
  676.                         ddeInstance, "TclEval", CP_WINANSI);
  677. returnPtr[i].hszTopic = DdeCreateStringHandle(
  678.                         ddeInstance, riPtr->name, CP_WINANSI);
  679.     }
  680.     returnPtr[i].hszSvc = NULL;
  681.     returnPtr[i].hszTopic = NULL;
  682.     DdeUnaccessData(ddeReturn);
  683.     return ddeReturn;
  684. }
  686.     }
  687.     return NULL;
  688. }
  690. /*
  691.  *--------------------------------------------------------------
  692.  *
  693.  * DdeExitProc --
  694.  *
  695.  * Gets rid of our DDE server when we go away.
  696.  *
  697.  * Results:
  698.  * None.
  699.  *
  700.  * Side effects:
  701.  * The DDE server is deleted.
  702.  *
  703.  *--------------------------------------------------------------
  704.  */
  706. static void
  707. DdeExitProc(
  708.     ClientData clientData)     /* Not used in this handler. */
  709. {
  710.     DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
  711.     DdeUninitialize(ddeInstance);
  712.     ddeInstance = 0;
  713. }
  715. /*
  716.  *--------------------------------------------------------------
  717.  *
  718.  * MakeDdeConnection --
  719.  *
  720.  * This procedure is a utility used to connect to a DDE
  721.  * server when given a server name and a topic name.
  722.  *
  723.  * Results:
  724.  * A standard Tcl result.
  725.  *
  726.  *
  727.  * Side effects:
  728.  * Passes back a conversation through ddeConvPtr
  729.  *
  730.  *--------------------------------------------------------------
  731.  */
  733. static int
  734. MakeDdeConnection(
  735.     Tcl_Interp *interp, /* Used to report errors. */
  736.     char *name, /* The connection to use. */
  737.     HCONV *ddeConvPtr)
  738. {
  739.     HSZ ddeTopic, ddeService;
  740.     HCONV ddeConv;
  741.     
  742.     ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
  743.     ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
  745.     ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
  746.     DdeFreeStringHandle(ddeInstance, ddeService);
  747.     DdeFreeStringHandle(ddeInstance, ddeTopic);
  749.     if (ddeConv == (HCONV) NULL) {
  750. if (interp != NULL) {
  751.     Tcl_AppendResult(interp, "no registered server named "",
  752.     name, """, (char *) NULL);
  753. }
  754. return TCL_ERROR;
  755.     }
  757.     *ddeConvPtr = ddeConv;
  758.     return TCL_OK;
  759. }
  761. /*
  762.  *--------------------------------------------------------------
  763.  *
  764.  * DdeGetServicesList --
  765.  *
  766.  * This procedure obtains the list of DDE services.
  767.  *
  768.  * The functions between here and this procedure are all
  769.  * involved with handling the DDE callbacks for this.
  770.  *
  771.  * Results:
  772.  * A standard Tcl result.
  773.  *
  774.  * Side effects:
  775.  * Sets the services list into the interp result.
  776.  *
  777.  *--------------------------------------------------------------
  778.  */
  780. typedef struct ddeEnumServices {
  781.     Tcl_Interp *interp;
  782.     int         result;
  783.     ATOM        service;
  784.     ATOM        topic;
  785.     HWND        hwnd;
  786. } ddeEnumServices;
  788. LRESULT CALLBACK
  789. DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam);
  790. static LRESULT
  791. DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam);
  793. static int
  794. DdeCreateClient(ddeEnumServices *es)
  795. {
  796.     WNDCLASSEX wc;
  797.     static const char *szDdeClientClassName = "TclEval client class";
  798.     static const char *szDdeClientWindowName = "TclEval client window";
  800.     memset(&wc, 0, sizeof(wc));
  801.     wc.cbSize = sizeof(wc);
  802.     wc.lpfnWndProc = DdeClientWindowProc;
  803.     wc.lpszClassName = szDdeClientClassName;
  804.     wc.cbWndExtra = sizeof(ddeEnumServices*);
  806.     /* register and create the callback window */
  807.     RegisterClassEx(&wc);
  808.     es->hwnd = CreateWindowEx(0, szDdeClientClassName,
  809.       szDdeClientWindowName,
  810.       WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL,
  811.       (LPVOID)es);
  812.     return TCL_OK;
  813. }
  815. LRESULT CALLBACK
  816. DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)
  817. {
  818.     LRESULT lr = 0L;
  820.     switch (uMsg) {
  821. case WM_CREATE: {
  822.     LPCREATESTRUCT lpcs = (LPCREATESTRUCT)lParam;
  823.     ddeEnumServices *es;
  824.     es = (ddeEnumServices*)lpcs->lpCreateParams;
  825. #ifdef _WIN64
  826.     SetWindowLongPtr(hwnd, GWLP_USERDATA, (long)es);
  827. #else
  828.     SetWindowLong(hwnd, GWL_USERDATA, (long)es);
  829. #endif
  830.     break;
  831. }
  832. case WM_DDE_ACK:
  833.     lr =  DdeServicesOnAck(hwnd, wParam, lParam);
  834.     break;
  835. default:
  836.     lr = DefWindowProc(hwnd, uMsg, wParam, lParam);
  837.     }
  838.     return lr;
  839. }
  841. static LRESULT
  842. DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam)
  843. {
  844.     HWND hwndRemote = (HWND)wParam;
  845.     ATOM service = (ATOM)LOWORD(lParam);
  846.     ATOM topic = (ATOM)HIWORD(lParam);
  847.     ddeEnumServices *es;
  848.     TCHAR sz[255];
  850. #ifdef _WIN64
  851.     es = (ddeEnumServices *)GetWindowLongPtr(hwnd, GWLP_USERDATA);
  852. #else
  853.     es = (ddeEnumServices *)GetWindowLong(hwnd, GWL_USERDATA);
  854. #endif
  856.     if ((es->service == (ATOM)NULL || es->service == service)
  857. && (es->topic == (ATOM)NULL || es->topic == topic)) {
  858. Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
  860. GlobalGetAtomName(service, sz, 255);
  861. Tcl_ListObjAppendElement(es->interp, matchPtr,
  862. Tcl_NewStringObj(sz, -1));
  863. GlobalGetAtomName(topic, sz, 255);
  864. Tcl_ListObjAppendElement(es->interp, matchPtr,
  865. Tcl_NewStringObj(sz, -1));
  866. /* Adding the hwnd as a third list element provides a unique
  867.  * identifier in the case of multiple servers with the name
  868.  * application and topic names.
  869.  */
  870. /* Needs a TIP though
  871.  * Tcl_ListObjAppendElement(es->interp, matchPtr,
  872.  * Tcl_NewLongObj((long)hwndRemote));
  873.  */
  874. Tcl_ListObjAppendElement(es->interp,
  875. Tcl_GetObjResult(es->interp), matchPtr);
  876.     }
  878.     /* tell the server we are no longer interested */
  879.     PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
  880.     return 0L;
  881. }
  883. static BOOL CALLBACK
  884. DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam)
  885. {
  886.     LRESULT dwResult = 0;
  887.     ddeEnumServices *es = (ddeEnumServices *)lParam;
  888.     SendMessageTimeout(hwndTarget, WM_DDE_INITIATE,
  889.        (WPARAM)es->hwnd,
  890.        MAKELONG(es->service, es->topic),
  891.        SMTO_ABORTIFHUNG, 1000, &dwResult);
  892.     return TRUE;
  893. }
  895. static int
  896. DdeGetServicesList(Tcl_Interp *interp, char *serviceName, char *topicName)
  897. {
  898.     ddeEnumServices es;
  899.     int r = TCL_OK;
  900.     es.interp = interp;
  901.     es.result = TCL_OK;
  902.     es.service = (serviceName == NULL) 
  903. ? (ATOM)NULL : GlobalAddAtom(serviceName);
  904.     es.topic = (topicName == NULL) 
  905. ? (ATOM)NULL : GlobalAddAtom(topicName);
  906.     
  907.     Tcl_ResetResult(interp); /* our list is to be appended to result. */
  908.     DdeCreateClient(&es);
  909.     EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es);
  910.     
  911.     if (IsWindow(es.hwnd))
  912.         DestroyWindow(es.hwnd);
  913.     if (es.service != (ATOM)NULL)
  914. GlobalDeleteAtom(es.service);
  915.     if (es.topic != (ATOM)NULL)
  916. GlobalDeleteAtom(es.topic);
  917.     return es.result;
  918. }
  920. /*
  921.  *--------------------------------------------------------------
  922.  *
  923.  * SetDdeError --
  924.  *
  925.  * Sets the interp result to a cogent error message
  926.  * describing the last DDE error.
  927.  *
  928.  * Results:
  929.  * None.
  930.  *
  931.  *
  932.  * Side effects:
  933.  * The interp's result object is changed.
  934.  *
  935.  *--------------------------------------------------------------
  936.  */
  938. static void
  939. SetDdeError(
  940.     Tcl_Interp *interp)     /* The interp to put the message in.*/
  941. {
  942.     Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
  943.     int err;
  945.     err = DdeGetLastError(ddeInstance);
  946.     switch (err) {
  947. case DMLERR_DATAACKTIMEOUT:
  948. case DMLERR_EXECACKTIMEOUT:
  949. case DMLERR_POKEACKTIMEOUT:
  950.     Tcl_SetStringObj(resultPtr,
  951.     "remote interpreter did not respond", -1);
  952.     break;
  954. case DMLERR_BUSY:
  955.     Tcl_SetStringObj(resultPtr, "remote server is busy", -1);
  956.     break;
  958. case DMLERR_NOTPROCESSED:
  959.     Tcl_SetStringObj(resultPtr, 
  960.     "remote server cannot handle this command", -1);
  961.     break;
  963. default:
  964.     Tcl_SetStringObj(resultPtr, "dde command failed", -1);
  965.     }
  966. }
  968. /*
  969.  *--------------------------------------------------------------
  970.  *
  971.  * Tcl_DdeObjCmd --
  972.  *
  973.  * This procedure is invoked to process the "dde" Tcl command.
  974.  * See the user documentation for details on what it does.
  975.  *
  976.  * Results:
  977.  * A standard Tcl result.
  978.  *
  979.  * Side effects:
  980.  * See the user documentation.
  981.  *
  982.  *--------------------------------------------------------------
  983.  */
  985. int
  986. Tcl_DdeObjCmd(
  987.     ClientData clientData, /* Used only for deletion */
  988.     Tcl_Interp *interp, /* The interp we are sending from */
  989.     int objc, /* Number of arguments */
  990.     Tcl_Obj *CONST objv[]) /* The arguments */
  991. {
  992.     enum {
  993. DDE_SERVERNAME,
  994. DDE_EXECUTE,
  995. DDE_POKE,
  996. DDE_REQUEST,
  997. DDE_SERVICES,
  998. DDE_EVAL
  999.     };
  1001.     static CONST char *ddeCommands[] = {"servername", "execute", "poke",
  1002.           "request", "services", "eval", 
  1003.   (char *) NULL};
  1004.     static CONST char *ddeOptions[] = {"-async", (char *) NULL};
  1005.     static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL};
  1006.     int index, argIndex;
  1007.     int async = 0, binary = 0;
  1008.     int result = TCL_OK;
  1009.     HSZ ddeService = NULL;
  1010.     HSZ ddeTopic = NULL;
  1011.     HSZ ddeItem = NULL;
  1012.     HDDEDATA ddeData = NULL;
  1013.     HDDEDATA ddeItemData = NULL;
  1014.     HCONV hConv = NULL;
  1015.     HSZ ddeCookie = 0;
  1016.     char *serviceName, *topicName, *itemString, *dataString;
  1017.     char *string;
  1018.     int firstArg, length, dataLength;
  1019.     DWORD ddeResult;
  1020.     HDDEDATA ddeReturn;
  1021.     RegisteredInterp *riPtr;
  1022.     Tcl_Interp *sendInterp;
  1023.     Tcl_Obj *objPtr;
  1024.     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
  1026.     /*
  1027.      * Initialize DDE server/client
  1028.      */
  1029.     
  1030.     if (objc < 2) {
  1031. Tcl_WrongNumArgs(interp, 1, objv, 
  1032. "?-async? serviceName topicName value");
  1033. return TCL_ERROR;
  1034.     }
  1036.     if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0,
  1037.     &index) != TCL_OK) {
  1038. return TCL_ERROR;
  1039.     }
  1041.     switch (index) {
  1042. case DDE_SERVERNAME:
  1043.     if ((objc != 3) && (objc != 2)) {
  1044. Tcl_WrongNumArgs(interp, 1, objv, "servername ?serverName?");
  1045. return TCL_ERROR;
  1046.     }
  1047.     firstArg = (objc - 1);
  1048.     break;
  1049. case DDE_EXECUTE:
  1050.     if ((objc < 5) || (objc > 6)) {
  1051. Tcl_WrongNumArgs(interp, 1, objv, 
  1052. "execute ?-async? serviceName topicName value");
  1053. return TCL_ERROR;
  1054.     }
  1055.     if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
  1056.     &argIndex) != TCL_OK) {
  1057. if (objc != 5) {
  1058.     Tcl_WrongNumArgs(interp, 1, objv,
  1059.     "execute ?-async? serviceName topicName value");
  1060.     return TCL_ERROR;
  1061. }
  1062. async = 0;
  1063. firstArg = 2;
  1064.     } else {
  1065. if (objc != 6) {
  1066.     Tcl_WrongNumArgs(interp, 1, objv,
  1067.     "execute ?-async? serviceName topicName value");
  1068.     return TCL_ERROR;
  1069. }
  1070. async = 1;
  1071. firstArg = 3;
  1072.     }
  1073.     break;
  1074.   case DDE_POKE:
  1075.     if (objc != 6) {
  1076. Tcl_WrongNumArgs(interp, 1, objv,
  1077. "poke serviceName topicName item value");
  1078. return TCL_ERROR;
  1079.     }
  1080.     firstArg = 2;
  1081.     break;
  1082. case DDE_REQUEST:
  1083.     if ((objc < 5) || (objc > 6)) {
  1084. Tcl_WrongNumArgs(interp, 1, objv, 
  1085. "request ?-binary? serviceName topicName value");
  1086. return TCL_ERROR;
  1087.     }
  1088.     if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
  1089.     &argIndex) != TCL_OK) {
  1090. if (objc != 5) {
  1091.     Tcl_WrongNumArgs(interp, 1, objv,
  1092.     "request ?-binary? serviceName topicName value");
  1093.     return TCL_ERROR;
  1094. }
  1095. binary = 0;
  1096. firstArg = 2;
  1097.     } else {
  1098. if (objc != 6) {
  1099.     Tcl_WrongNumArgs(interp, 1, objv,
  1100.     "request ?-binary? serviceName topicName value");
  1101.     return TCL_ERROR;
  1102. }
  1103. binary = 1;
  1104. firstArg = 3;
  1105.     }
  1106.     break;
  1107. case DDE_SERVICES:
  1108.     if (objc != 4) {
  1109. Tcl_WrongNumArgs(interp, 1, objv,
  1110. "services serviceName topicName");
  1111. return TCL_ERROR;
  1112.     }
  1113.     firstArg = 2;
  1114.     break;
  1115. case DDE_EVAL:
  1116.     if (objc < 4) {
  1117. Tcl_WrongNumArgs(interp, 1, objv, 
  1118. "eval ?-async? serviceName args");
  1119. return TCL_ERROR;
  1120.     }
  1121.     if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
  1122.     &argIndex) != TCL_OK) {
  1123. if (objc < 4) {
  1124.     Tcl_WrongNumArgs(interp, 1, objv,
  1125.     "eval ?-async? serviceName args");
  1126.     return TCL_ERROR;
  1127. }
  1128. async = 0;
  1129. firstArg = 2;
  1130.     } else {
  1131. if (objc < 5) {
  1132.     Tcl_WrongNumArgs(interp, 1, objv,
  1133.     "eval ?-async? serviceName args");
  1134.     return TCL_ERROR;
  1135. }
  1136. async = 1;
  1137. firstArg = 3;
  1138.     }
  1139.     break;
  1140.     }
  1142.     Initialize();
  1144.     if (firstArg != 1) {
  1145. serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
  1146.     } else {
  1147. length = 0;
  1148.     }
  1150.     if (length == 0) {
  1151. serviceName = NULL;
  1152.     } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
  1153. ddeService = DdeCreateStringHandle(ddeInstance, serviceName,
  1154. CP_WINANSI);
  1155.     }
  1157.     if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) {
  1158. topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
  1159. if (length == 0) {
  1160.     topicName = NULL;
  1161. } else {
  1162.     ddeTopic = DdeCreateStringHandle(ddeInstance, 
  1163.     topicName, CP_WINANSI);
  1164. }
  1165.     }
  1167.     switch (index) {
  1168. case DDE_SERVERNAME: {
  1169.     serviceName = DdeSetServerName(interp, serviceName);
  1170.     if (serviceName != NULL) {
  1171. Tcl_SetStringObj(Tcl_GetObjResult(interp),
  1172. serviceName, -1);
  1173.     } else {
  1174. Tcl_ResetResult(interp);
  1175.     }
  1176.     break;
  1177. }
  1178. case DDE_EXECUTE: {
  1179.     dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
  1180.     if (dataLength == 0) {
  1181. Tcl_SetStringObj(Tcl_GetObjResult(interp),
  1182. "cannot execute null data", -1);
  1183. result = TCL_ERROR;
  1184. break;
  1185.     }
  1186.     hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
  1187.     DdeFreeStringHandle(ddeInstance, ddeService);
  1188.     DdeFreeStringHandle(ddeInstance, ddeTopic);
  1190.     if (hConv == NULL) {
  1191. SetDdeError(interp);
  1192. result = TCL_ERROR;
  1193. break;
  1194.     }
  1196.     ddeData = DdeCreateDataHandle(ddeInstance, dataString,
  1197.     (DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
  1198.     if (ddeData != NULL) {
  1199. if (async) {
  1200.     DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, 
  1201.     CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
  1202.     DdeAbandonTransaction(ddeInstance, hConv, 
  1203.     ddeResult);
  1204. } else {
  1205.     ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
  1206.     hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
  1207.     if (ddeReturn == 0) {
  1208. SetDdeError(interp);
  1209. result = TCL_ERROR;
  1210.     }
  1211. }
  1212. DdeFreeDataHandle(ddeData);
  1213.     } else {
  1214. SetDdeError(interp);
  1215. result = TCL_ERROR;
  1216.     }
  1217.     break;
  1218. }
  1219. case DDE_REQUEST: {
  1220.     itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
  1221.     if (length == 0) {
  1222. Tcl_SetStringObj(Tcl_GetObjResult(interp),
  1223. "cannot request value of null data", -1);
  1224. goto errorNoResult;
  1225.     }
  1226.     hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
  1227.     DdeFreeStringHandle(ddeInstance, ddeService);
  1228.     DdeFreeStringHandle(ddeInstance, ddeTopic);
  1229.     
  1230.     if (hConv == NULL) {
  1231. SetDdeError(interp);
  1232. result = TCL_ERROR;
  1233.     } else {
  1234. Tcl_Obj *returnObjPtr;
  1235. ddeItem = DdeCreateStringHandle(ddeInstance, 
  1236.                         itemString, CP_WINANSI);
  1237. if (ddeItem != NULL) {
  1238.     ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
  1239.     CF_TEXT, XTYP_REQUEST, 5000, NULL);
  1240.     if (ddeData == NULL) {
  1241. SetDdeError(interp);
  1242. result = TCL_ERROR;
  1243.     } else {
  1244. DWORD tmp;
  1245. dataString = DdeAccessData(ddeData, &tmp);
  1246. dataLength = tmp;
  1247. if (binary) {
  1248.     returnObjPtr = Tcl_NewByteArrayObj(dataString,
  1249.     dataLength);
  1250. } else {
  1251.     returnObjPtr = Tcl_NewStringObj(dataString, -1);
  1252. }
  1253. DdeUnaccessData(ddeData);
  1254. DdeFreeDataHandle(ddeData);
  1255. Tcl_SetObjResult(interp, returnObjPtr);
  1256.     }
  1257. } else {
  1258.     SetDdeError(interp);
  1259.     result = TCL_ERROR;
  1260. }
  1261.     }
  1263.     break;
  1264. }
  1265. case DDE_POKE: {
  1266.     itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
  1267.     if (length == 0) {
  1268. Tcl_SetStringObj(Tcl_GetObjResult(interp),
  1269. "cannot have a null item", -1);
  1270. goto errorNoResult;
  1271.     }
  1272.     dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
  1273.     
  1274.     hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
  1275.     DdeFreeStringHandle(ddeInstance, ddeService);
  1276.     DdeFreeStringHandle(ddeInstance, ddeTopic);
  1278.     if (hConv == NULL) {
  1279. SetDdeError(interp);
  1280. result = TCL_ERROR;
  1281.     } else {
  1282. ddeItem = DdeCreateStringHandle(ddeInstance, itemString,
  1283. CP_WINANSI);
  1284. if (ddeItem != NULL) {
  1285.     ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
  1286.     hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
  1287.     if (ddeData == NULL) {
  1288. SetDdeError(interp);
  1289. result = TCL_ERROR;
  1290.     }
  1291. } else {
  1292.     SetDdeError(interp);
  1293.     result = TCL_ERROR;
  1294. }
  1295.     }
  1296.     break;
  1297. }
  1299. case DDE_SERVICES: {
  1300.     result = DdeGetServicesList(interp, serviceName, topicName);
  1301.     break;
  1302. }
  1303. case DDE_EVAL: {
  1304.     if (serviceName == NULL) {
  1305. Tcl_SetStringObj(Tcl_GetObjResult(interp),
  1306. "invalid service name """, -1);
  1307. goto errorNoResult;
  1308.     }
  1310.     objc -= (async + 3);
  1311.     ((Tcl_Obj **) objv) += (async + 3);
  1313.             /*
  1314.      * See if the target interpreter is local.  If so, execute
  1315.      * the command directly without going through the DDE server.
  1316.      * Don't exchange objects between interps.  The target interp could
  1317.      * compile an object, producing a bytecode structure that refers to 
  1318.      * other objects owned by the target interp.  If the target interp 
  1319.      * is then deleted, the bytecode structure would be referring to 
  1320.      * deallocated objects.
  1321.      */
  1322.     
  1323.     for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
  1324.  riPtr = riPtr->nextPtr) {
  1325. if (stricmp(serviceName, riPtr->name) == 0) {
  1326.     break;
  1327. }
  1328.     }
  1330.     if (riPtr != NULL) {
  1331. /*
  1332.  * This command is to a local interp. No need to go through
  1333.  * the server.
  1334.  */
  1336. Tcl_Preserve((ClientData) riPtr);
  1337. sendInterp = riPtr->interp;
  1338. Tcl_Preserve((ClientData) sendInterp);
  1340. /*
  1341.  * Don't exchange objects between interps.  The target interp
  1342.  * would compile an object, producing a bytecode structure that
  1343.  * refers to other objects owned by the target interp.  If the
  1344.  * target interp is then deleted, the bytecode structure would
  1345.  * be referring to deallocated objects.
  1346.  */
  1348. if (objc == 1) {
  1349.     result = Tcl_EvalObjEx(sendInterp, objv[0],
  1350.     TCL_EVAL_GLOBAL);
  1351. } else {
  1352.     objPtr = Tcl_ConcatObj(objc, objv);
  1353.     Tcl_IncrRefCount(objPtr);
  1354.     result = Tcl_EvalObjEx(sendInterp, objPtr,
  1355.     TCL_EVAL_GLOBAL);
  1356.     Tcl_DecrRefCount(objPtr);
  1357. }
  1358. if (interp != sendInterp) {
  1359.     if (result == TCL_ERROR) {
  1360. /*
  1361.  * An error occurred, so transfer error information
  1362.  * from the destination interpreter back to our
  1363.  * interpreter.
  1364.  */
  1366. Tcl_ResetResult(interp);
  1367. objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, 
  1368. TCL_GLOBAL_ONLY);
  1369. string = Tcl_GetStringFromObj(objPtr, &length);
  1370. Tcl_AddObjErrorInfo(interp, string, length);
  1372. objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
  1373. TCL_GLOBAL_ONLY);
  1374. Tcl_SetObjErrorCode(interp, objPtr);
  1375.     }
  1376.     Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
  1377. }
  1378. Tcl_Release((ClientData) riPtr);
  1379. Tcl_Release((ClientData) sendInterp);
  1380.     } else {
  1381. /*
  1382.  * This is a non-local request. Send the script to the server
  1383.  * and poll it for a result.
  1384.  */
  1386. if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
  1387.     goto error;
  1388. }
  1390. objPtr = Tcl_ConcatObj(objc, objv);
  1391. string = Tcl_GetStringFromObj(objPtr, &length);
  1392. ddeItemData = DdeCreateDataHandle(ddeInstance, string,
  1393. (DWORD) length+1, 0, 0, CF_TEXT, 0);
  1395. if (async) {
  1396.     ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
  1397.     0xFFFFFFFF, hConv, 0,
  1398.     CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
  1399.     DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
  1400. } else {
  1401.     ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
  1402.     0xFFFFFFFF, hConv, 0,
  1403.     CF_TEXT, XTYP_EXECUTE, 30000, NULL);
  1404.     if (ddeData != 0) {
  1406. ddeCookie = DdeCreateStringHandle(ddeInstance, 
  1407. "$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
  1408. ddeData = DdeClientTransaction(NULL, 0, hConv,
  1409. ddeCookie, CF_TEXT, XTYP_REQUEST, 30000, NULL);
  1410.     }
  1411. }
  1413. Tcl_DecrRefCount(objPtr);
  1415. if (ddeData == 0) {
  1416.     SetDdeError(interp);
  1417.     goto errorNoResult;
  1418. }
  1420. if (async == 0) {
  1421.     Tcl_Obj *resultPtr;
  1422.     
  1423.     /*
  1424.      * The return handle has a two or four element list in
  1425.      * it. The first element is the return code (TCL_OK,
  1426.      * TCL_ERROR, etc.). The second is the result of the
  1427.      * script. If the return code is TCL_ERROR, then the third
  1428.      * element is the value of the variable "errorCode", and
  1429.      * the fourth is the value of the variable "errorInfo".
  1430.      */
  1431.     
  1432.     resultPtr = Tcl_NewObj();
  1433.     length = DdeGetData(ddeData, NULL, 0, 0);
  1434.     Tcl_SetObjLength(resultPtr, length);
  1435.     string = Tcl_GetString(resultPtr);
  1436.     DdeGetData(ddeData, string, (DWORD) length, 0);
  1437.     Tcl_SetObjLength(resultPtr, (int) strlen(string));
  1438.     
  1439.     if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr)
  1440.     != TCL_OK) {
  1441. Tcl_DecrRefCount(resultPtr);
  1442. goto error;
  1443.     }
  1444.     if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
  1445. Tcl_DecrRefCount(resultPtr);
  1446. goto error;
  1447.     }
  1448.     if (result == TCL_ERROR) {
  1449. Tcl_ResetResult(interp);
  1451. if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr)
  1452. != TCL_OK) {
  1453.     Tcl_DecrRefCount(resultPtr);
  1454.     goto error;
  1455. }
  1456. length = -1;
  1457. string = Tcl_GetStringFromObj(objPtr, &length);
  1458. Tcl_AddObjErrorInfo(interp, string, length);
  1460. Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
  1461. Tcl_SetObjErrorCode(interp, objPtr);
  1462.     }
  1463.     if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr)
  1464.     != TCL_OK) {
  1465. Tcl_DecrRefCount(resultPtr);
  1466. goto error;
  1467.     }
  1468.     Tcl_SetObjResult(interp, objPtr);
  1469.     Tcl_DecrRefCount(resultPtr);
  1470. }
  1471.     }
  1472. }
  1473.     }
  1474.     if (ddeCookie != NULL) {
  1475. DdeFreeStringHandle(ddeInstance, ddeCookie);
  1476.     }
  1477.     if (ddeItem != NULL) {
  1478. DdeFreeStringHandle(ddeInstance, ddeItem);
  1479.     }
  1480.     if (ddeItemData != NULL) {
  1481. DdeFreeDataHandle(ddeItemData);
  1482.     }
  1483.     if (ddeData != NULL) {
  1484. DdeFreeDataHandle(ddeData);
  1485.     }
  1486.     if (hConv != NULL) {
  1487. DdeDisconnect(hConv);
  1488.     }
  1489.     return result;
  1491.     error:
  1492.     Tcl_SetStringObj(Tcl_GetObjResult(interp),
  1493.     "invalid data returned from server", -1);
  1495.     errorNoResult:
  1496.     if (ddeCookie != NULL) {
  1497. DdeFreeStringHandle(ddeInstance, ddeCookie);
  1498.     }
  1499.     if (ddeItem != NULL) {
  1500. DdeFreeStringHandle(ddeInstance, ddeItem);
  1501.     }
  1502.     if (ddeItemData != NULL) {
  1503. DdeFreeDataHandle(ddeItemData);
  1504.     }
  1505.     if (ddeData != NULL) {
  1506. DdeFreeDataHandle(ddeData);
  1507.     }
  1508.     if (hConv != NULL) {
  1509. DdeDisconnect(hConv);
  1510.     }
  1511.     return TCL_ERROR;
  1512. }