--- /dev/null
+
+/*
+ * bltWinDde.c --
+ *
+ * This file provides procedures that implement the "send"
+ * command, allowing commands to be passed from interpreter
+ * to interpreter.
+ *
+ * Copyright (c) 1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: bltWinDde.c,v 1.1.1.1 2009/05/09 16:27:07 pcmacdon Exp $
+ */
+
+#include "bltInt.h"
+
+#ifndef NO_DDE
+
+#include <ddeml.h>
+
+/*
+ * The following structure is used to keep track of the interpreters
+ * registered by this process.
+ */
+
+typedef struct RegisteredInterp {
+ struct RegisteredInterp *nextPtr;
+ /* The next interp this application knows
+ * about. */
+ Tcl_Interp *interp; /* The interpreter attached to this name. */
+ char name[1]; /* Interpreter's name. Malloc-ed as
+ * part of the structure. */
+} RegisteredInterp;
+
+/*
+ * Used to keep track of conversations.
+ */
+
+typedef struct Conversation {
+ struct Conversation *nextPtr;
+ /* The next conversation in the list. */
+ RegisteredInterp *riPtr; /* The info we know about the conversation. */
+ HCONV hConv; /* The DDE handle for this conversation. */
+ Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
+
+} Conversation;
+
+static Conversation *conversations; /* A list of conversations currently
+ * being processed. */
+static RegisteredInterp *interps; /* List of all interpreters registered
+ * in the current process. */
+static HSZ globalService;
+static DWORD instance; /* The application instance handle given
+ * to us by DdeInitialize. */
+static int isServer;
+
+#define TCL_DDE_VERSION "1.2"
+#define TCL_DDE_PACKAGE_NAME "dde"
+#define TCL_DDE_SERVICE_NAME "TclEval"
+
+/*
+ * Forward declarations for procedures defined later in this file.
+ */
+
+static Tcl_Obj *ExecuteRemoteObject _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static int MakeConnection _ANSI_ARGS_((Tcl_Interp *interp, char *name,
+ HCONV *convPtr));
+static HDDEDATA CALLBACK ServerProc _ANSI_ARGS_((UINT uType, UINT uFmt,
+ HCONV hConv, HSZ topic, HSZ item, HDDEDATA hData, DWORD dwData1,
+ DWORD dwData2));
+
+static Tcl_ExitProc ExitProc;
+static Tcl_CmdDeleteProc DeleteProc;
+static void SetError _ANSI_ARGS_((Tcl_Interp *interp));
+
+static Tcl_ObjCmdProc DdeObjCmd;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Initialize --
+ *
+ * Initialize the global DDE instance.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Registers the DDE server proc.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+Initialize(void)
+{
+ int nameFound = 0;
+
+ /*
+ * See if the application is already registered; if so, remove its
+ * current name from the registry. The deletion of the command
+ * will take care of disposing of this entry.
+ */
+
+ if (interps != NULL) {
+ nameFound = 1;
+ }
+
+ /*
+ * Make sure that the DDE server is there. This is done only once,
+ * add an exit handler tear it down.
+ */
+
+ if (instance == 0) {
+ if (instance == 0) {
+ unsigned int flags;
+
+ flags = (CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS |
+ CBF_FAIL_POKES);
+ if (DdeInitialize(&instance, ServerProc, flags, 0)
+ != DMLERR_NO_ERROR) {
+ instance = 0;
+ }
+ }
+ }
+ if ((globalService == 0) && (nameFound != 0)) {
+ if ((globalService == 0) && (nameFound != 0)) {
+ isServer = TRUE;
+ Tcl_CreateExitHandler(ExitProc, NULL);
+ globalService = DdeCreateStringHandle(instance,
+ TCL_DDE_SERVICE_NAME, 0);
+ DdeNameService(instance, globalService, 0L, DNS_REGISTER);
+ } else {
+ isServer = FALSE;
+ }
+ }
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * SetServerName --
+ *
+ * This procedure is called to associate an ASCII name with a Dde
+ * server. If the interpreter has already been named, the
+ * name replaces the old one.
+ *
+ * Results:
+ * The return value is the name actually given to the interp.
+ * This will normally be the same as name, but if name was already
+ * in use for a Dde Server then a name of the form "name #2" will
+ * be chosen, with a high enough number to make the name unique.
+ *
+ * Side effects:
+ * Registration info is saved, thereby allowing the "send" command
+ * to be used later to invoke commands in the application. In
+ * addition, the "send" command is created in the application's
+ * interpreter. The registration will be removed automatically
+ * if the interpreter is deleted or the "send" command is removed.
+ *
+ *--------------------------------------------------------------
+ */
+
+static char *
+SetServerName(
+ Tcl_Interp *interp,
+ char *name /* The name that will be used to
+ * refer to the interpreter in later
+ * "send" commands. Must be globally
+ * unique. */
+ )
+{
+ int suffix, offset;
+ RegisteredInterp *riPtr, *prevPtr;
+ Tcl_DString dString;
+
+ /*
+ * See if the application is already registered; if so, remove its
+ * current name from the registry. The deletion of the command
+ * will take care of disposing of this entry.
+ */
+
+ for (riPtr = interps, prevPtr = NULL; riPtr != NULL;
+ prevPtr = riPtr, riPtr = riPtr->nextPtr) {
+ if (riPtr->interp == interp) {
+ if (name != NULL) {
+ if (prevPtr == NULL) {
+ interps = interps->nextPtr;
+ } else {
+ prevPtr->nextPtr = riPtr->nextPtr;
+ }
+ break;
+ } else {
+ /*
+ * the name was NULL, so the caller is asking for
+ * the name of the current interp.
+ */
+
+ return riPtr->name;
+ }
+ }
+ }
+
+ if (name == NULL) {
+ /*
+ * the name was NULL, so the caller is asking for
+ * the name of the current interp, but it doesn't
+ * have a name.
+ */
+
+ return "";
+ }
+
+ /*
+ * Pick a name to use for the application. Use "name" if it's not
+ * already in use. Otherwise add a suffix such as " #2", trying
+ * larger and larger numbers until we eventually find one that is
+ * unique.
+ */
+
+ suffix = 1;
+ offset = 0;
+ Tcl_DStringInit(&dString);
+
+ /*
+ * We have found a unique name. Now add it to the registry.
+ */
+
+ riPtr = Blt_Malloc(sizeof(RegisteredInterp) + strlen(name));
+ riPtr->interp = interp;
+ riPtr->nextPtr = interps;
+ interps = riPtr;
+ strcpy(riPtr->name, name);
+
+ Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, riPtr, DeleteProc);
+ if (Tcl_IsSafe(interp)) {
+ Tcl_HideCommand(interp, "dde", "dde");
+ }
+ Tcl_DStringFree(&dString);
+
+ /*
+ * re-initialize with the new name
+ */
+ Initialize();
+
+ return riPtr->name;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * DeleteProc
+ *
+ * This procedure is called when the command "dde" is destroyed.
+ *
+ * Results:
+ * none
+ *
+ * Side effects:
+ * The interpreter given by riPtr is unregistered.
+ *
+ *--------------------------------------------------------------
+ */
+
+static void
+DeleteProc(clientData)
+ ClientData clientData; /* The interp we are deleting passed
+ * as ClientData. */
+{
+ RegisteredInterp *riPtr = clientData;
+ RegisteredInterp *searchPtr, *prevPtr;
+
+ for (searchPtr = interps, prevPtr = NULL;
+ (searchPtr != NULL) && (searchPtr != riPtr);
+ prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+ }
+
+ if (searchPtr != NULL) {
+ if (prevPtr == NULL) {
+ interps = interps->nextPtr;
+ } else {
+ prevPtr->nextPtr = searchPtr->nextPtr;
+ }
+ }
+ Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * ExecuteRemoteObject --
+ *
+ * Takes the package delivered by DDE and executes it in
+ * the server's interpreter.
+ *
+ * Results:
+ * A list Tcl_Obj * that describes what happened. The first
+ * element is the numerical return code (TCL_ERROR, etc.).
+ * The second element is the result of the script. If the
+ * return result was TCL_ERROR, then the third element
+ * will be the value of the global "errorCode", and the
+ * fourth will be the value of the global "errorInfo".
+ * The return result will have a refCount of 0.
+ *
+ * Side effects:
+ * A Tcl script is run, which can cause all kinds of other
+ * things to happen.
+ *
+ *--------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ExecuteRemoteObject(
+ Tcl_Interp *interp, /* Remote interpreter. */
+ Tcl_Obj *objPtr) /* The object to execute. */
+{
+ Tcl_Obj *listObjPtr;
+ int result;
+
+ result = Tcl_GlobalEval(interp, Tcl_GetString(objPtr));
+ listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ Tcl_ListObjAppendElement(NULL, listObjPtr, Tcl_NewIntObj(result));
+ Tcl_ListObjAppendElement(NULL, listObjPtr, Tcl_GetObjResult(interp));
+ if (result == TCL_ERROR) {
+ char *value;
+ Tcl_Obj *objPtr;
+
+ value = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
+ objPtr = Tcl_NewStringObj(value, -1);
+ Tcl_ListObjAppendElement(NULL, listObjPtr, objPtr);
+ value = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
+ objPtr = Tcl_NewStringObj(value, -1);
+ Tcl_ListObjAppendElement(NULL, listObjPtr, objPtr);
+ }
+ return listObjPtr;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * ServerProc --
+ *
+ * Handles all transactions for this server. Can handle
+ * execute, request, and connect protocols. Dde will
+ * call this routine when a client attempts to run a dde
+ * command using this server.
+ *
+ * Results:
+ * A DDE Handle with the result of the dde command.
+ *
+ * Side effects:
+ * Depending on which command is executed, arbitrary
+ * Tcl scripts can be run.
+ *
+ *--------------------------------------------------------------
+ */
+
+static HDDEDATA CALLBACK
+ServerProc (
+ UINT uType, /* The type of DDE transaction we
+ * are performing. */
+ UINT uFmt, /* The format that data is sent or
+ * received. */
+ HCONV hConv, /* The conversation associated with the
+ * current transaction. */
+ HSZ topic, /* A string handle. Transaction-type
+ * dependent. */
+ HSZ item, /* A string handle. Transaction-type
+ * dependent. */
+ HDDEDATA hData, /* DDE data. Transaction-type dependent. */
+ DWORD dwData1, /* Transaction-dependent data. */
+ DWORD dwData2) /* Transaction-dependent data. */
+{
+ Tcl_DString dString;
+ char *utilString;
+ Tcl_Obj *objPtr;
+ HDDEDATA code = NULL;
+ RegisteredInterp *riPtr;
+ Conversation *convPtr, *prevConvPtr;
+
+ switch(uType) {
+ case XTYP_CONNECT:
+ {
+ int length;
+
+ /*
+ * Dde is trying to initialize a conversation with us. Check
+ * and make sure we have a valid topic.
+ */
+
+ length = DdeQueryString(instance, topic, NULL, 0, 0);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, length);
+ utilString = Tcl_DStringValue(&dString);
+ DdeQueryString(instance, topic, utilString, length + 1,
+ CP_WINANSI);
+
+ for (riPtr = interps; riPtr != NULL; riPtr = riPtr->nextPtr) {
+ if (strcasecmp(utilString, riPtr->name) == 0) {
+ Tcl_DStringFree(&dString);
+ return (HDDEDATA) TRUE;
+ }
+ }
+
+ Tcl_DStringFree(&dString);
+ return (HDDEDATA) FALSE;
+ }
+ case XTYP_CONNECT_CONFIRM:
+ {
+ DWORD length;
+
+ /*
+ * Dde has decided that we can connect, so it gives us a
+ * conversation handle. We need to keep track of it
+ * so we know which execution result to return in an
+ * XTYP_REQUEST.
+ */
+
+ length = DdeQueryString(instance, topic, NULL, 0, 0);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, length);
+ utilString = Tcl_DStringValue(&dString);
+ DdeQueryString(instance, topic, utilString, length + 1,
+ CP_WINANSI);
+ for (riPtr = interps; riPtr != NULL; riPtr = riPtr->nextPtr) {
+ if (strcasecmp(riPtr->name, utilString) == 0) {
+ convPtr = Blt_Malloc(sizeof(Conversation));
+ convPtr->nextPtr = conversations;
+ convPtr->returnPackagePtr = NULL;
+ convPtr->hConv = hConv;
+ convPtr->riPtr = riPtr;
+ conversations = convPtr;
+ break;
+ }
+ }
+ Tcl_DStringFree(&dString);
+ return (HDDEDATA) TRUE;
+ }
+ case XTYP_DISCONNECT:
+ {
+ /*
+ * The client has disconnected from our server. Forget this
+ * conversation.
+ */
+
+ for (convPtr = conversations, prevConvPtr = NULL;
+ convPtr != NULL;
+ prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
+ if (hConv == convPtr->hConv) {
+ if (prevConvPtr == NULL) {
+ conversations = convPtr->nextPtr;
+ } else {
+ prevConvPtr->nextPtr = convPtr->nextPtr;
+ }
+ if (convPtr->returnPackagePtr != NULL) {
+ Tcl_DecrRefCount(convPtr->returnPackagePtr);
+ }
+ Blt_Free(convPtr);
+ break;
+ }
+ }
+ return (HDDEDATA) TRUE;
+ }
+ case XTYP_REQUEST:
+ {
+ int length;
+
+ /*
+ * This could be either a request for a value of a Tcl variable,
+ * or it could be the send command requesting the results of the
+ * last execute.
+ */
+
+ if (uFmt != CF_TEXT) {
+ return (HDDEDATA) FALSE;
+ }
+
+ code = (HDDEDATA) FALSE;
+ for (convPtr = conversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+ }
+
+ if (convPtr != NULL) {
+ length = DdeQueryString(instance, item, NULL, 0, CP_WINANSI);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, length);
+ utilString = Tcl_DStringValue(&dString);
+ DdeQueryString(instance, item, utilString, length + 1,
+ CP_WINANSI);
+ if (strcasecmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) {
+ char *value;
+
+ value = Tcl_GetStringFromObj(convPtr->returnPackagePtr,
+ &length);
+ code = DdeCreateDataHandle(instance, value, length+1, 0,
+ item, CF_TEXT, 0);
+ } else {
+ char *value;
+
+ value = Tcl_GetVar2(convPtr->riPtr->interp, utilString,
+ NULL, TCL_GLOBAL_ONLY);
+ if (value != NULL) {
+ length = strlen(value);
+ code = DdeCreateDataHandle(instance, value, length+1,
+ 0, item, CF_TEXT, 0);
+ } else {
+ code = NULL;
+ }
+ }
+ Tcl_DStringFree(&dString);
+ }
+ return code;
+ }
+ case XTYP_EXECUTE:
+ {
+ DWORD length;
+ /*
+ * Execute this script. The results will be saved into
+ * a list object which will be retreived later. See
+ * ExecuteRemoteObject.
+ */
+
+ Tcl_Obj *returnPackagePtr;
+
+ for (convPtr = conversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+
+ }
+
+ if (convPtr == NULL) {
+ return (HDDEDATA) DDE_FNOTPROCESSED;
+ }
+
+ utilString = (char *) DdeAccessData(hData, &length);
+ objPtr = Tcl_NewStringObj(utilString, -1);
+ Tcl_IncrRefCount(objPtr);
+ DdeUnaccessData(hData);
+ if (convPtr->returnPackagePtr != NULL) {
+ Tcl_DecrRefCount(convPtr->returnPackagePtr);
+ }
+ convPtr->returnPackagePtr = NULL;
+ returnPackagePtr = ExecuteRemoteObject(convPtr->riPtr->interp,
+ objPtr);
+ for (convPtr = conversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+
+ }
+ if (convPtr != NULL) {
+ Tcl_IncrRefCount(returnPackagePtr);
+ convPtr->returnPackagePtr = returnPackagePtr;
+ }
+ Tcl_DecrRefCount(objPtr);
+ if (returnPackagePtr == NULL) {
+ return (HDDEDATA) DDE_FNOTPROCESSED;
+ } else {
+ return (HDDEDATA) DDE_FACK;
+ }
+ }
+ case XTYP_WILDCONNECT:
+ {
+ DWORD length;
+
+ /*
+ * Dde wants a list of services and topics that we support.
+ */
+
+ HSZPAIR *returnPtr;
+ int i;
+ int numItems;
+
+ for (i = 0, riPtr = interps; riPtr != NULL;
+ i++, riPtr = riPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+
+ }
+
+ numItems = i;
+ code = DdeCreateDataHandle(instance, NULL,
+ (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
+ returnPtr = (HSZPAIR *) DdeAccessData(code, &length);
+ for (i = 0, riPtr = interps; i < numItems;
+ i++, riPtr = riPtr->nextPtr) {
+ returnPtr[i].hszSvc = DdeCreateStringHandle(
+ instance, "TclEval", CP_WINANSI);
+ returnPtr[i].hszTopic = DdeCreateStringHandle(
+ instance, riPtr->name, CP_WINANSI);
+ }
+ returnPtr[i].hszSvc = NULL;
+ returnPtr[i].hszTopic = NULL;
+ DdeUnaccessData(code);
+ return code;
+ }
+ }
+ return NULL;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * ExitProc --
+ *
+ * Gets rid of our DDE server when we go away.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The DDE server is deleted.
+ *
+ *--------------------------------------------------------------
+ */
+
+static void
+ExitProc(
+ ClientData clientData) /* Not used in this handler. */
+{
+ DdeNameService(instance, NULL, 0, DNS_UNREGISTER);
+ DdeUninitialize(instance);
+ instance = 0;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * MakeConnection --
+ *
+ * This procedure is a utility used to connect to a DDE
+ * server when given a server name and a topic name.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ *
+ * Side effects:
+ * Passes back a conversation through ddeConvPtr
+ *
+ *--------------------------------------------------------------
+ */
+
+static int
+MakeConnection(
+ Tcl_Interp *interp, /* Used to report errors. */
+ char *name, /* The connection to use. */
+ HCONV *convPtr)
+{
+ HSZ topic, service;
+ HCONV conv;
+
+ service = DdeCreateStringHandle(instance, "TclEval", 0);
+ topic = DdeCreateStringHandle(instance, name, 0);
+
+ conv = DdeConnect(instance, service, topic, NULL);
+ DdeFreeStringHandle(instance, service);
+ DdeFreeStringHandle(instance, topic);
+
+ if (conv == NULL) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "no registered server named \"", name,
+ "\"", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ *convPtr = conv;
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * SetError --
+ *
+ * Sets the interp result to a cogent error message
+ * describing the last DDE error.
+ *
+ * Results:
+ * None.
+ *
+ *
+ * Side effects:
+ * The interp's result object is changed.
+ *
+ *--------------------------------------------------------------
+ */
+
+static void
+SetError(
+ Tcl_Interp *interp) /* The interp to put the message in.*/
+{
+ int err;
+ char *mesg;
+
+ err = DdeGetLastError(instance);
+ switch (err) {
+ case DMLERR_DATAACKTIMEOUT:
+ case DMLERR_EXECACKTIMEOUT:
+ case DMLERR_POKEACKTIMEOUT:
+ mesg = "remote interpreter did not respond";
+ break;
+
+ case DMLERR_BUSY:
+ mesg = "remote server is busy";
+ break;
+
+ case DMLERR_NOTPROCESSED:
+ mesg = "remote server cannot handle this command";
+ break;
+
+ default:
+ mesg = "dde command failed";
+ break;
+ }
+ Tcl_SetResult(interp, mesg, TCL_VOLATILE);
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * DdeObjCmd --
+ *
+ * This procedure is invoked to process the "dde" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+
+static int
+DdeObjCmd(
+ ClientData clientData, /* Used only for deletion */
+ Tcl_Interp *interp, /* The interp we are sending from */
+ int objc, /* Number of arguments */
+ Tcl_Obj *CONST objv[]) /* The arguments */
+{
+ enum {
+ DDE_SERVERNAME,
+ DDE_EXECUTE,
+ DDE_POKE,
+ DDE_REQUEST,
+ DDE_SERVICES,
+ DDE_EVAL
+ };
+
+ static char *commands[] = {
+ "servername", "execute", "poke", "request", "services", "eval",
+ (char *) NULL
+ };
+ static char *options[] = {
+ "-async", (char *) NULL
+ };
+ int index, argIndex;
+ int async = 0, binary = 0;
+ int result = TCL_OK;
+ HSZ service = NULL;
+ HSZ topic = NULL;
+ HSZ item = NULL;
+ HDDEDATA data = NULL;
+ HDDEDATA itemData = NULL;
+ HCONV hConv = NULL;
+ HSZ cookie = 0;
+ char *serviceName, *topicName, *itemString, *dataString;
+ char *string;
+ int firstArg, length, dataLength;
+ HDDEDATA code;
+ RegisteredInterp *riPtr;
+ Tcl_Interp *sendInterp;
+ Tcl_Obj *objPtr;
+
+ /*
+ * Initialize DDE server/client
+ */
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?-async? serviceName topicName value");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ serviceName = NULL; /* Suppress compiler warning. */
+ firstArg = 1;
+ switch (index) {
+ case DDE_SERVERNAME:
+ if ((objc != 3) && (objc != 2)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "servername ?serverName?");
+ return TCL_ERROR;
+ }
+ firstArg = (objc - 1);
+ break;
+
+ case DDE_EXECUTE:
+ if ((objc < 5) || (objc > 6)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "execute ?-async? serviceName topicName value");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(NULL, objv[2], options, "option", 0,
+ &argIndex) != TCL_OK) {
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "execute ?-async? serviceName topicName value");
+ return TCL_ERROR;
+ }
+ async = 0;
+ firstArg = 2;
+ } else {
+ if (objc != 6) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "execute ?-async? serviceName topicName value");
+ return TCL_ERROR;
+ }
+ async = 1;
+ firstArg = 3;
+ }
+ break;
+ case DDE_POKE:
+ if (objc != 6) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "poke serviceName topicName item value");
+ return TCL_ERROR;
+ }
+ firstArg = 2;
+ break;
+
+ case DDE_REQUEST:
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "request serviceName topicName value");
+ return TCL_ERROR;
+ }
+ binary = 0;
+ firstArg = 2;
+ break;
+
+ case DDE_SERVICES:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "services serviceName topicName");
+ return TCL_ERROR;
+ }
+ firstArg = 2;
+ break;
+
+ case DDE_EVAL:
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "eval ?-async? serviceName args");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(NULL, objv[2], options, "option", 0,
+ &argIndex) != TCL_OK) {
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "eval ?-async? serviceName args");
+ return TCL_ERROR;
+ }
+ async = 0;
+ firstArg = 2;
+ } else {
+ if (objc < 5) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "eval ?-async? serviceName args");
+ return TCL_ERROR;
+ }
+ async = 1;
+ firstArg = 3;
+ }
+ break;
+ }
+
+ Initialize();
+
+ if (firstArg != 1) {
+ serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
+ } else {
+ length = 0;
+ }
+
+ if (length == 0) {
+ serviceName = NULL;
+ } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
+ service = DdeCreateStringHandle(instance, serviceName,
+ CP_WINANSI);
+ }
+
+ if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) {
+ topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
+ if (length == 0) {
+ topicName = NULL;
+ } else {
+ topic = DdeCreateStringHandle(instance, topicName, CP_WINANSI);
+ }
+ }
+
+ switch (index) {
+ case DDE_SERVERNAME:
+ serviceName = SetServerName(interp, serviceName);
+ if (serviceName != NULL) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ serviceName, -1);
+ } else {
+ Tcl_ResetResult(interp);
+ }
+ break;
+
+ case DDE_EXECUTE:
+ {
+ dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
+ if (dataLength == 0) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "cannot execute null data", -1);
+ result = TCL_ERROR;
+ break;
+ }
+ hConv = DdeConnect(instance, service, topic, NULL);
+ DdeFreeStringHandle(instance, service);
+ DdeFreeStringHandle(instance, topic);
+
+ if (hConv == NULL) {
+ SetError(interp);
+ result = TCL_ERROR;
+ break;
+ }
+
+ data = DdeCreateDataHandle(instance, dataString, dataLength + 1,
+ 0, 0, CF_TEXT, 0);
+ if (data != NULL) {
+ if (async) {
+ DWORD status;
+
+ DdeClientTransaction((LPBYTE) data, 0xFFFFFFFF, hConv, 0,
+ CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &status);
+ DdeAbandonTransaction(instance, hConv, status);
+ } else {
+ code = DdeClientTransaction((LPBYTE) data, 0xFFFFFFFF,
+ hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
+ if (code == 0) {
+ SetError(interp);
+ result = TCL_ERROR;
+ }
+ }
+ DdeFreeDataHandle(data);
+ } else {
+ SetError(interp);
+ result = TCL_ERROR;
+ }
+ break;
+ }
+ case DDE_REQUEST:
+ {
+ itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
+ if (length == 0) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "cannot request value of null data", -1);
+ return TCL_ERROR;
+ }
+ hConv = DdeConnect(instance, service, topic, NULL);
+ DdeFreeStringHandle(instance, service);
+ DdeFreeStringHandle(instance, topic);
+
+ if (hConv == NULL) {
+ SetError(interp);
+ result = TCL_ERROR;
+ } else {
+ item = DdeCreateStringHandle(instance, itemString, CP_WINANSI);
+ if (item != NULL) {
+ data = DdeClientTransaction(NULL, 0, hConv, item, CF_TEXT,
+ XTYP_REQUEST, 5000, NULL);
+ if (data == NULL) {
+ SetError(interp);
+ result = TCL_ERROR;
+ } else {
+ Tcl_Obj *objPtr;
+ DWORD dataLength;
+
+ dataString = DdeAccessData(data, &dataLength);
+ objPtr = Tcl_NewStringObj(dataString, -1);
+ DdeUnaccessData(data);
+ DdeFreeDataHandle(data);
+ Tcl_SetObjResult(interp, objPtr);
+ }
+ } else {
+ SetError(interp);
+ result = TCL_ERROR;
+ }
+ }
+
+ break;
+ }
+ case DDE_POKE:
+ {
+ itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
+ if (length == 0) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "cannot have a null item", -1);
+ return TCL_ERROR;
+ }
+ dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
+
+ hConv = DdeConnect(instance, service, topic, NULL);
+ DdeFreeStringHandle(instance, service);
+ DdeFreeStringHandle(instance, topic);
+
+ if (hConv == NULL) {
+ SetError(interp);
+ result = TCL_ERROR;
+ } else {
+ item = DdeCreateStringHandle(instance, itemString,
+ CP_WINANSI);
+ if (item != NULL) {
+ data = DdeClientTransaction(dataString,length+1,
+ hConv, item, CF_TEXT, XTYP_POKE, 5000, NULL);
+ if (data == NULL) {
+ SetError(interp);
+ result = TCL_ERROR;
+ }
+ } else {
+ SetError(interp);
+ result = TCL_ERROR;
+ }
+ }
+ break;
+ }
+
+ case DDE_SERVICES:
+ {
+ HCONVLIST hConvList;
+ CONVINFO convInfo;
+ Tcl_Obj *convListObjPtr, *elementObjPtr;
+ Tcl_DString dString;
+ char *name;
+
+ convInfo.cb = sizeof(CONVINFO);
+ hConvList = DdeConnectList(instance, service,
+ topic, 0, NULL);
+ DdeFreeStringHandle(instance, service);
+ DdeFreeStringHandle(instance, topic);
+ hConv = 0;
+ convListObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ Tcl_DStringInit(&dString);
+
+ while (hConv = DdeQueryNextServer(hConvList, hConv), hConv != 0) {
+ elementObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ DdeQueryConvInfo(hConv, QID_SYNC, &convInfo);
+ length = DdeQueryString(instance,
+ convInfo.hszSvcPartner, NULL, 0, CP_WINANSI);
+ Tcl_DStringSetLength(&dString, length);
+ name = Tcl_DStringValue(&dString);
+ DdeQueryString(instance, convInfo.hszSvcPartner,
+ name, length + 1, CP_WINANSI);
+ Tcl_ListObjAppendElement(interp, elementObjPtr,
+ Tcl_NewStringObj(name, length));
+ length = DdeQueryString(instance, convInfo.hszTopic,
+ NULL, 0, CP_WINANSI);
+ Tcl_DStringSetLength(&dString, length);
+ name = Tcl_DStringValue(&dString);
+ DdeQueryString(instance, convInfo.hszTopic, name,
+ length + 1, CP_WINANSI);
+ Tcl_ListObjAppendElement(interp, elementObjPtr,
+ Tcl_NewStringObj(name, length));
+ Tcl_ListObjAppendElement(interp, convListObjPtr,
+ elementObjPtr);
+ }
+ DdeDisconnectList(hConvList);
+ Tcl_SetObjResult(interp, convListObjPtr);
+ Tcl_DStringFree(&dString);
+ break;
+ }
+ case DDE_EVAL:
+ {
+ objc -= (async + 3);
+ ((Tcl_Obj **) objv) += (async + 3);
+
+ /*
+ * See if the target interpreter is local. If so, execute
+ * the command directly without going through the DDE
+ * server. Don't exchange objects between interps. The
+ * target interp could compile an object, producing a
+ * bytecode structure that refers to other objects owned
+ * by the target interp. If the target interp is then
+ * deleted, the bytecode structure would be referring to
+ * deallocated objects.
+ */
+
+ for (riPtr = interps; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
+ if (strcasecmp(serviceName, riPtr->name) == 0) {
+ break;
+ }
+ }
+
+ if (riPtr != NULL) {
+ /*
+ * This command is to a local interp. No need to go through
+ * the server.
+ */
+
+ Tcl_Preserve(riPtr);
+ sendInterp = riPtr->interp;
+ Tcl_Preserve(sendInterp);
+
+ /*
+ * Don't exchange objects between interps. The target interp
+ * would compile an object, producing a bytecode structure that
+ * refers to other objects owned by the target interp. If the
+ * target interp is then deleted, the bytecode structure would
+ * be referring to deallocated objects.
+ */
+
+ if (objc == 1) {
+ result = Tcl_GlobalEval(sendInterp,Tcl_GetString(objv[0]));
+ } else {
+ objPtr = Tcl_ConcatObj(objc, objv);
+ Tcl_IncrRefCount(objPtr);
+ result = Tcl_GlobalEval(sendInterp, Tcl_GetString(objPtr));
+ Tcl_DecrRefCount(objPtr);
+ }
+ if (interp != sendInterp) {
+ if (result == TCL_ERROR) {
+ char *value;
+ /*
+ * An error occurred, so transfer error information
+ * from the destination interpreter back to our
+ * interpreter.
+ */
+
+ Tcl_ResetResult(interp);
+ value = Tcl_GetVar2(sendInterp, "errorInfo", NULL,
+ TCL_GLOBAL_ONLY);
+ Tcl_AddObjErrorInfo(interp, value, length);
+
+ value = Tcl_GetVar2(sendInterp, "errorCode", NULL,
+ TCL_GLOBAL_ONLY);
+ Tcl_SetErrorCode(interp, value, (char *)NULL);
+ }
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
+ }
+ Tcl_Release(riPtr);
+ Tcl_Release(sendInterp);
+ } else {
+ /*
+ * This is a non-local request. Send the script to the server
+ * and poll it for a result.
+ */
+
+ if (MakeConnection(interp, serviceName, &hConv) != TCL_OK) {
+ goto error;
+ }
+
+ objPtr = Tcl_ConcatObj(objc, objv);
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ itemData = DdeCreateDataHandle(instance, string,
+ length+1, 0, 0, CF_TEXT, 0);
+
+ if (async) {
+ DWORD status;
+
+ data = DdeClientTransaction((LPBYTE) itemData, 0xFFFFFFFF,
+ hConv, 0, CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC,
+ &status);
+ DdeAbandonTransaction(instance, hConv, status);
+ } else {
+ data = DdeClientTransaction((LPBYTE) itemData,
+ 0xFFFFFFFF, hConv, 0,
+ CF_TEXT, XTYP_EXECUTE, 30000, NULL);
+ if (data != 0) {
+
+ cookie = DdeCreateStringHandle(instance,
+ "$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
+ data = DdeClientTransaction(NULL, 0, hConv,
+ cookie, CF_TEXT, XTYP_REQUEST, 30000, NULL);
+ }
+ }
+
+ Tcl_DecrRefCount(objPtr);
+
+ if (data == 0) {
+ SetError(interp);
+ goto errorNoResult;
+ }
+
+ if (async == 0) {
+ Tcl_Obj *resultPtr;
+
+ /*
+ * The return handle has a two or four element list in
+ * it. The first element is the return code (TCL_OK,
+ * TCL_ERROR, etc.). The second is the result of the
+ * script. If the return code is TCL_ERROR, then the third
+ * element is the value of the variable "errorCode", and
+ * the fourth is the value of the variable "errorInfo".
+ */
+
+ resultPtr = Tcl_NewObj();
+ length = DdeGetData(data, NULL, 0, 0);
+ Tcl_SetObjLength(resultPtr, length);
+ string = Tcl_GetString(resultPtr);
+ DdeGetData(data, string, length, 0);
+ Tcl_SetObjLength(resultPtr, strlen(string));
+
+ if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr)
+ != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ goto error;
+ }
+ if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ goto error;
+ }
+ if (result == TCL_ERROR) {
+ Tcl_ResetResult(interp);
+
+ if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr)
+ != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ goto error;
+ }
+ length = -1;
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_AddObjErrorInfo(interp, string, length);
+
+ Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
+ Tcl_SetObjErrorCode(interp, objPtr);
+ }
+ if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr)
+ != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ goto error;
+ }
+ Tcl_SetObjResult(interp, objPtr);
+ Tcl_DecrRefCount(resultPtr);
+ }
+ }
+ }
+ }
+ if (cookie != NULL) {
+ DdeFreeStringHandle(instance, cookie);
+ }
+ if (item != NULL) {
+ DdeFreeStringHandle(instance, item);
+ }
+ if (itemData != NULL) {
+ DdeFreeDataHandle(itemData);
+ }
+ if (data != NULL) {
+ DdeFreeDataHandle(data);
+ }
+ if (hConv != NULL) {
+ DdeDisconnect(hConv);
+ }
+ return result;
+
+ error:
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "invalid data returned from server", -1);
+
+ errorNoResult:
+ if (cookie != NULL) {
+ DdeFreeStringHandle(instance, cookie);
+ }
+ if (item != NULL) {
+ DdeFreeStringHandle(instance, item);
+ }
+ if (itemData != NULL) {
+ DdeFreeDataHandle(itemData);
+ }
+ if (data != NULL) {
+ DdeFreeDataHandle(data);
+ }
+ if (hConv != NULL) {
+ DdeDisconnect(hConv);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Blt_DdeInit --
+ *
+ * This procedure initializes the dde command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Blt_DdeInit(interp)
+ Tcl_Interp *interp;
+{
+ Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
+ conversations = NULL;
+ interps = NULL;
+ Tcl_CreateExitHandler(ExitProc, NULL);
+ return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
+}
+
+#endif /* NO_DDE */
OSDN Git Service
