/*
* tclWinDde.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: tclWinDde.c,v 1.13.2.1 2003/11/10 22:42:07 dgp Exp $
*/
#include "tclPort.h"
#include <ddeml.h>
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
* Registry_Init declaration is in the source file itself, which is only
* accessed when we are building a library.
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
/*
* The following structure is used to keep track of the interpreters
* registered by this process.
*/
typedef struct RegisteredInterp {
struct RegisteredInterp *nextPtr;
/* The next interp this application knows
* about. */
char *name; /* Interpreter's name (malloc-ed). */
Tcl_Interp *interp; /* The interpreter attached to this name. */
} RegisteredInterp;
/*
* Used to keep track of conversations.
*/
typedef struct Conversation {
struct Conversation *nextPtr;
/* The next conversation in the list. */
RegisteredInterp *riPtr; /* The info we know about the conversation. */
HCONV hConv; /* The DDE handle for this conversation. */
Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
} Conversation;
typedef struct ThreadSpecificData {
Conversation *currentConversations;
/* A list of conversations currently
* being processed. */
RegisteredInterp *interpListPtr;
/* List of all interpreters registered
* in the current process. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* The following variables cannot be placed in thread-local storage.
* The Mutex ddeMutex guards access to the ddeInstance.
*/
static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance; /* The application instance handle given
* to us by DdeInitialize. */
static int ddeIsServer = 0;
#define TCL_DDE_VERSION "1.2.2"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME "TclEval"
TCL_DECLARE_MUTEX(ddeMutex)
/*
* Forward declarations for procedures defined later in this file.
*/
static void DdeExitProc _ANSI_ARGS_((ClientData clientData));
static void DeleteProc _ANSI_ARGS_((ClientData clientData));
static Tcl_Obj * ExecuteRemoteObject _ANSI_ARGS_((
RegisteredInterp *riPtr,
Tcl_Obj *ddeObjectPtr));
static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp,
char *name, HCONV *ddeConvPtr));
static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType,
UINT uFmt, HCONV hConv, HSZ ddeTopic,
HSZ ddeItem, HDDEDATA hData, DWORD dwData1,
DWORD dwData2));
static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp));
int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */
Tcl_Interp *interp, /* The interp we are sending from */
int objc, /* Number of arguments */
Tcl_Obj *CONST objv[]); /* The arguments */
EXTERN int Dde_Init(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
*
* Dde_Init --
*
* This procedure initializes the dde command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Dde_Init(
Tcl_Interp *interp)
{
ThreadSpecificData *tsdPtr;
if (!Tcl_InitStubs(interp, "8.0", 0)) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL);
tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_CreateExitHandler(DdeExitProc, NULL);
return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
}
/*
*----------------------------------------------------------------------
*
* Initialize --
*
* Initialize the global DDE instance.
*
* Results:
* None.
*
* Side effects:
* Registers the DDE server proc.
*
*----------------------------------------------------------------------
*/
static void
Initialize(void)
{
int nameFound = 0;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* See if the application is already registered; if so, remove its
* current name from the registry. The deletion of the command
* will take care of disposing of this entry.
*/
if (tsdPtr->interpListPtr != NULL) {
nameFound = 1;
}
/*
* Make sure that the DDE server is there. This is done only once,
* add an exit handler tear it down.
*/
if (ddeInstance == 0) {
Tcl_MutexLock(&ddeMutex);
if (ddeInstance == 0) {
if (DdeInitialize(&ddeInstance, DdeServerProc,
CBF_SKIP_REGISTRATIONS
| CBF_SKIP_UNREGISTRATIONS
| CBF_FAIL_POKES, 0)
!= DMLERR_NO_ERROR) {
ddeInstance = 0;
}
}
Tcl_MutexUnlock(&ddeMutex);
}
if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
Tcl_MutexLock(&ddeMutex);
if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
ddeIsServer = 1;
Tcl_CreateExitHandler(DdeExitProc, NULL);
ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, \
TCL_DDE_SERVICE_NAME, 0);
DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
} else {
ddeIsServer = 0;
}
Tcl_MutexUnlock(&ddeMutex);
}
}
/*
*--------------------------------------------------------------
*
* DdeSetServerName --
*
* This 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 *
DdeSetServerName(
Tcl_Interp *interp,
char *name /* The name that will be used to
* refer to the interpreter in later
* "send" commands. Must be globally
* unique. */
)
{
int suffix, offset;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* See if the application is already registered; if so, remove its
* current name from the registry. The deletion of the command
* will take care of disposing of this entry.
*/
for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
prevPtr = riPtr, riPtr = riPtr->nextPtr) {
if (riPtr->interp == interp) {
if (name != NULL) {
if (prevPtr == NULL) {
tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
} else {
prevPtr->nextPtr = riPtr->nextPtr;
}
break;
} else {
/*
* the name was NULL, so the caller is asking for
* the name of the current interp.
*/
return riPtr->name;
}
}
}
if (name == NULL) {
/*
* the name was NULL, so the caller is asking for
* the name of the current interp, but it doesn't
* have a name.
*/
return "";
}
/*
* 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 = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
riPtr->name = ckalloc(strlen(name) + 1);
riPtr->nextPtr = tsdPtr->interpListPtr;
tsdPtr->interpListPtr = riPtr;
strcpy(riPtr->name, name);
Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
(ClientData) riPtr, DeleteProc);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "dde", "dde");
}
Tcl_DStringFree(&dString);
/*
* re-initialize with the new name
*/
Initialize();
return riPtr->name;
}
/*
*--------------------------------------------------------------
*
* 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 = (RegisteredInterp *) clientData;
RegisteredInterp *searchPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
(searchPtr != NULL) && (searchPtr != riPtr);
prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
/*
* Empty loop body.
*/
}
if (searchPtr != NULL) {
if (prevPtr == NULL) {
tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
} else {
prevPtr->nextPtr = searchPtr->nextPtr;
}
}
ckfree(riPtr->name);
Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
}
/*
*--------------------------------------------------------------
*
* ExecuteRemoteObject --
*
* Takes the package delivered by DDE and executes it in
* the server's interpreter.
*
* Results:
* A list Tcl_Obj * that describes what happened. The first
* element is the numerical return code (TCL_ERROR, etc.).
* The second element is the result of the script. If the
* return result was TCL_ERROR, then the third element
* will be the value of the global "errorCode", and the
* fourth will be the value of the global "errorInfo".
* The return result will have a refCount of 0.
*
* Side effects:
* A Tcl script is run, which can cause all kinds of other
* things to happen.
*
*--------------------------------------------------------------
*/
static Tcl_Obj *
ExecuteRemoteObject(
RegisteredInterp *riPtr, /* Info about this server. */
Tcl_Obj *ddeObjectPtr) /* The object to execute. */
{
Tcl_Obj *errorObjPtr;
Tcl_Obj *returnPackagePtr;
int result;
result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
Tcl_NewIntObj(result));
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
Tcl_GetObjResult(riPtr->interp));
if (result == TCL_ERROR) {
errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
}
return returnPackagePtr;
}
/*
*--------------------------------------------------------------
*
* DdeServerProc --
*
* Handles all transactions for this server. Can handle
* execute, request, and connect protocols. Dde will
* call this routine when a client attempts to run a dde
* command using this server.
*
* Results:
* A DDE Handle with the result of the dde command.
*
* Side effects:
* Depending on which command is executed, arbitrary
* Tcl scripts can be run.
*
*--------------------------------------------------------------
*/
static HDDEDATA CALLBACK
DdeServerProc (
UINT uType, /* The type of DDE transaction we
* are performing. */
UINT uFmt, /* The format that data is sent or
* received. */
HCONV hConv, /* The conversation associated with the
* current transaction. */
HSZ ddeTopic, /* A string handle. Transaction-type
* dependent. */
HSZ ddeItem, /* 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;
int len;
DWORD dlen;
char *utilString;
Tcl_Obj *ddeObjectPtr;
HDDEDATA ddeReturn = NULL;
RegisteredInterp *riPtr;
Conversation *convPtr, *prevConvPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
switch(uType) {
case XTYP_CONNECT:
/*
* Dde is trying to initialize a conversation with us. Check
* and make sure we have a valid topic.
*/
len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
Tcl_DStringInit(&dString);
Tcl_DStringSetLength(&dString, len);
utilString = Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
CP_WINANSI);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (stricmp(utilString, riPtr->name) == 0) {
Tcl_DStringFree(&dString);
return (HDDEDATA) TRUE;
}
}
Tcl_DStringFree(&dString);
return (HDDEDATA) FALSE;
case XTYP_CONNECT_CONFIRM:
/*
* Dde has decided that we can connect, so it gives us a
* conversation handle. We need to keep track of it
* so we know which execution result to return in an
* XTYP_REQUEST.
*/
len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
Tcl_DStringInit(&dString);
Tcl_DStringSetLength(&dString, len);
utilString = Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
CP_WINANSI);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (stricmp(riPtr->name, utilString) == 0) {
convPtr = (Conversation *) ckalloc(sizeof(Conversation));
convPtr->nextPtr = tsdPtr->currentConversations;
convPtr->returnPackagePtr = NULL;
convPtr->hConv = hConv;
convPtr->riPtr = riPtr;
tsdPtr->currentConversations = convPtr;
break;
}
}
Tcl_DStringFree(&dString);
return (HDDEDATA) TRUE;
case XTYP_DISCONNECT:
/*
* The client has disconnected from our server. Forget this
* conversation.
*/
for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
convPtr != NULL;
prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
if (hConv == convPtr->hConv) {
if (prevConvPtr == NULL) {
tsdPtr->currentConversations = convPtr->nextPtr;
} else {
prevConvPtr->nextPtr = convPtr->nextPtr;
}
if (convPtr->returnPackagePtr != NULL) {
Tcl_DecrRefCount(convPtr->returnPackagePtr);
}
ckfree((char *) convPtr);
break;
}
}
return (HDDEDATA) TRUE;
case XTYP_REQUEST:
/*
* This could be either a request for a value of a Tcl variable,
* or it could be the send command requesting the results of the
* last execute.
*/
if (uFmt != CF_TEXT) {
return (HDDEDATA) FALSE;
}
ddeReturn = (HDDEDATA) FALSE;
for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
* Empty loop body.
*/
}
if (convPtr != NULL) {
char *returnString;
len = DdeQueryString(ddeInstance, ddeItem, NULL, 0,
CP_WINANSI);
Tcl_DStringInit(&dString);
Tcl_DStringSetLength(&dString, len);
utilString = Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeItem, utilString,
(DWORD) len + 1, CP_WINANSI);
if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) {
returnString =
Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
ddeReturn = DdeCreateDataHandle(ddeInstance,
returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT,
0);
} else {
Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
convPtr->riPtr->interp, utilString, NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
returnString = Tcl_GetStringFromObj(variableObjPtr,
&len);
ddeReturn = DdeCreateDataHandle(ddeInstance,
returnString, (DWORD) len+1, 0, ddeItem,
CF_TEXT, 0);
} else {
ddeReturn = NULL;
}
}
Tcl_DStringFree(&dString);
}
return ddeReturn;
case XTYP_EXECUTE: {
/*
* Execute this script. The results will be saved into
* a list object which will be retreived later. See
* ExecuteRemoteObject.
*/
Tcl_Obj *returnPackagePtr;
for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
* Empty loop body.
*/
}
if (convPtr == NULL) {
return (HDDEDATA) DDE_FNOTPROCESSED;
}
utilString = (char *) DdeAccessData(hData, &dlen);
len = dlen;
ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
Tcl_IncrRefCount(ddeObjectPtr);
DdeUnaccessData(hData);
if (convPtr->returnPackagePtr != NULL) {
Tcl_DecrRefCount(convPtr->returnPackagePtr);
}
convPtr->returnPackagePtr = NULL;
returnPackagePtr =
ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
Tcl_IncrRefCount(returnPackagePtr);
for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
* Empty loop body.
*/
}
if (convPtr != NULL) {
convPtr->returnPackagePtr = returnPackagePtr;
} else {
Tcl_DecrRefCount(returnPackagePtr);
}
Tcl_DecrRefCount(ddeObjectPtr);
if (returnPackagePtr == NULL) {
return (HDDEDATA) DDE_FNOTPROCESSED;
} else {
return (HDDEDATA) DDE_FACK;
}
}
case XTYP_WILDCONNECT: {
/*
* Dde wants a list of services and topics that we support.
*/
HSZPAIR *returnPtr;
int i;
int numItems;
for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL;
i++, riPtr = riPtr->nextPtr) {
/*
* Empty loop body.
*/
}
numItems = i;
ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
(numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
len = dlen;
for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
i++, riPtr = riPtr->nextPtr) {
returnPtr[i].hszSvc = DdeCreateStringHandle(
ddeInstance, "TclEval", CP_WINANSI);
returnPtr[i].hszTopic = DdeCreateStringHandle(
ddeInstance, riPtr->name, CP_WINANSI);
}
returnPtr[i].hszSvc = NULL;
returnPtr[i].hszTopic = NULL;
DdeUnaccessData(ddeReturn);
return ddeReturn;
}
}
return NULL;
}
/*
*--------------------------------------------------------------
*
* DdeExitProc --
*
* Gets rid of our DDE server when we go away.
*
* Results:
* None.
*
* Side effects:
* The DDE server is deleted.
*
*--------------------------------------------------------------
*/
static void
DdeExitProc(
ClientData clientData) /* Not used in this handler. */
{
DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
DdeUninitialize(ddeInstance);
ddeInstance = 0;
}
/*
*--------------------------------------------------------------
*
* MakeDdeConnection --
*
* This 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
MakeDdeConnection(
Tcl_Interp *interp, /* Used to report errors. */
char *name, /* The connection to use. */
HCONV *ddeConvPtr)
{
HSZ ddeTopic, ddeService;
HCONV ddeConv;
ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (ddeConv == (HCONV) NULL) {
if (interp != NULL) {
Tcl_AppendResult(interp, "no registered server named \"",
name, "\"", (char *) NULL);
}
return TCL_ERROR;
}
*ddeConvPtr = ddeConv;
return TCL_OK;
}
/*
*--------------------------------------------------------------
*
* SetDdeError --
*
* Sets the interp result to a cogent error message
* describing the last DDE error.
*
* Results:
* None.
*
*
* Side effects:
* The interp's result object is changed.
*
*--------------------------------------------------------------
*/
static void
SetDdeError(
Tcl_Interp *interp) /* The interp to put the message in.*/
{
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
int err;
err = DdeGetLastError(ddeInstance);
switch (err) {
case DMLERR_DATAACKTIMEOUT:
case DMLERR_EXECACKTIMEOUT:
case DMLERR_POKEACKTIMEOUT:
Tcl_SetStringObj(resultPtr,
"remote interpreter did not respond", -1);
break;
case DMLERR_BUSY:
Tcl_SetStringObj(resultPtr, "remote server is busy", -1);
break;
case DMLERR_NOTPROCESSED:
Tcl_SetStringObj(resultPtr,
"remote server cannot handle this command", -1);
break;
default:
Tcl_SetStringObj(resultPtr, "dde command failed", -1);
}
}
/*
*--------------------------------------------------------------
*
* Tcl_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.
*
*--------------------------------------------------------------
*/
int
Tcl_DdeObjCmd(
ClientData clientData, /* Used only for deletion */
Tcl_Interp *interp, /* The interp we are sending from */
int objc, /* Number of arguments */
Tcl_Obj *CONST objv[]) /* The arguments */
{
enum {
DDE_SERVERNAME,
DDE_EXECUTE,
DDE_POKE,
DDE_REQUEST,
DDE_SERVICES,
DDE_EVAL
};
static CONST char *ddeCommands[] = {"servername", "execute", "poke",
"request", "services", "eval",
(char *) NULL};
static CONST char *ddeOptions[] = {"-async", (char *) NULL};
static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL};
int index, argIndex;
int async = 0, binary = 0;
int result = TCL_OK;
HSZ ddeService = NULL;
HSZ ddeTopic = NULL;
HSZ ddeItem = NULL;
HDDEDATA ddeData = NULL;
HDDEDATA ddeItemData = NULL;
HCONV hConv = NULL;
HSZ ddeCookie = 0;
char *serviceName, *topicName, *itemString, *dataString;
char *string;
int firstArg, length, dataLength;
DWORD ddeResult;
HDDEDATA ddeReturn;
RegisteredInterp *riPtr;
Tcl_Interp *sendInterp;
Tcl_Obj *objPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* 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], ddeCommands, "command", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
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], ddeOptions, "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) || (objc > 6)) {
Tcl_WrongNumArgs(interp, 1, objv,
"request ?-binary? serviceName topicName value");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
&argIndex) != TCL_OK) {
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
"request ?-binary? serviceName topicName value");
return TCL_ERROR;
}
binary = 0;
firstArg = 2;
} else {
if (objc != 6) {
Tcl_WrongNumArgs(interp, 1, objv,
"request ?-binary? serviceName topicName value");
return TCL_ERROR;
}
binary = 1;
firstArg = 3;
}
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], ddeOptions, "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)) {
ddeService = DdeCreateStringHandle(ddeInstance, serviceName,
CP_WINANSI);
}
if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) {
topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
if (length == 0) {
topicName = NULL;
} else {
ddeTopic = DdeCreateStringHandle(ddeInstance,
topicName, CP_WINANSI);
}
}
switch (index) {
case DDE_SERVERNAME: {
serviceName = DdeSetServerName(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(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
break;
}
ddeData = DdeCreateDataHandle(ddeInstance, dataString,
(DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
if (ddeData != NULL) {
if (async) {
DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv,
ddeResult);
} else {
ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeReturn == 0) {
SetDdeError(interp);
result = TCL_ERROR;
}
}
DdeFreeDataHandle(ddeData);
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
break;
}
case DDE_REQUEST: {
itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
if (length == 0) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"cannot request value of null data", -1);
goto errorNoResult;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
Tcl_Obj *returnObjPtr;
ddeItem = DdeCreateStringHandle(ddeInstance,
itemString, CP_WINANSI);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
CF_TEXT, XTYP_REQUEST, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
DWORD tmp;
dataString = DdeAccessData(ddeData, &tmp);
dataLength = tmp;
if (binary) {
returnObjPtr = Tcl_NewByteArrayObj(dataString,
dataLength);
} else {
returnObjPtr = Tcl_NewStringObj(dataString, -1);
}
DdeUnaccessData(ddeData);
DdeFreeDataHandle(ddeData);
Tcl_SetObjResult(interp, returnObjPtr);
}
} else {
SetDdeError(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);
goto errorNoResult;
}
dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
ddeItem = DdeCreateStringHandle(ddeInstance, itemString,
CP_WINANSI);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
}
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
}
break;
}
case DDE_SERVICES: {
HCONVLIST hConvList;
CONVINFO convInfo;
Tcl_Obj *convListObjPtr, *elementObjPtr;
Tcl_DString dString;
char *name;
convInfo.cb = sizeof(CONVINFO);
hConvList = DdeConnectList(ddeInstance, ddeService,
ddeTopic, 0, NULL);
DdeFreeStringHandle(ddeInstance,ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
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(ddeInstance,
convInfo.hszSvcPartner, NULL, 0, CP_WINANSI);
Tcl_DStringSetLength(&dString, length);
name = Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, convInfo.hszSvcPartner,
name, (DWORD) length + 1, CP_WINANSI);
Tcl_ListObjAppendElement(interp, elementObjPtr,
Tcl_NewStringObj(name, length));
length = DdeQueryString(ddeInstance, convInfo.hszTopic,
NULL, 0, CP_WINANSI);
Tcl_DStringSetLength(&dString, length);
name = Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, convInfo.hszTopic, name,
(DWORD) 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: {
if (serviceName == NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"invalid service name \"\"", -1);
goto errorNoResult;
}
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 = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (stricmp(serviceName, riPtr->name) == 0) {
break;
}
}
if (riPtr != NULL) {
/*
* This command is to a local interp. No need to go through
* the server.
*/
Tcl_Preserve((ClientData) riPtr);
sendInterp = riPtr->interp;
Tcl_Preserve((ClientData) sendInterp);
/*
* Don't exchange objects between interps. The target interp
* would compile an object, producing a bytecode structure that
* refers to other objects owned by the target interp. If the
* target interp is then deleted, the bytecode structure would
* be referring to deallocated objects.
*/
if (objc == 1) {
result = Tcl_EvalObjEx(sendInterp, objv[0],
TCL_EVAL_GLOBAL);
} else {
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
result = Tcl_EvalObjEx(sendInterp, objPtr,
TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(objPtr);
}
if (interp != sendInterp) {
if (result == TCL_ERROR) {
/*
* An error occurred, so transfer error information
* from the destination interpreter back to our
* interpreter.
*/
Tcl_ResetResult(interp);
objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
string = Tcl_GetStringFromObj(objPtr, &length);
Tcl_AddObjErrorInfo(interp, string, length);
objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
Tcl_SetObjErrorCode(interp, objPtr);
}
Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
}
Tcl_Release((ClientData) riPtr);
Tcl_Release((ClientData) sendInterp);
} else {
/*
* This is a non-local request. Send the script to the server
* and poll it for a result.
*/
if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
goto error;
}
objPtr = Tcl_ConcatObj(objc, objv);
string = Tcl_GetStringFromObj(objPtr, &length);
ddeItemData = DdeCreateDataHandle(ddeInstance, string,
(DWORD) length+1, 0, 0, CF_TEXT, 0);
if (async) {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
CF_TEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeData != 0) {
ddeCookie = DdeCreateStringHandle(ddeInstance,
"$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
ddeData = DdeClientTransaction(NULL, 0, hConv,
ddeCookie, CF_TEXT, XTYP_REQUEST, 30000, NULL);
}
}
Tcl_DecrRefCount(objPtr);
if (ddeData == 0) {
SetDdeError(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(ddeData, NULL, 0, 0);
Tcl_SetObjLength(resultPtr, length);
string = Tcl_GetString(resultPtr);
DdeGetData(ddeData, string, (DWORD) length, 0);
Tcl_SetObjLength(resultPtr, (int) strlen(string));
if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr)
!= TCL_OK) {
Tcl_DecrRefCount(resultPtr);
goto 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 (ddeCookie != NULL) {
DdeFreeStringHandle(ddeInstance, ddeCookie);
}
if (ddeItem != NULL) {
DdeFreeStringHandle(ddeInstance, ddeItem);
}
if (ddeItemData != NULL) {
DdeFreeDataHandle(ddeItemData);
}
if (ddeData != NULL) {
DdeFreeDataHandle(ddeData);
}
if (hConv != NULL) {
DdeDisconnect(hConv);
}
return result;
error:
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"invalid data returned from server", -1);
errorNoResult:
if (ddeCookie != NULL) {
DdeFreeStringHandle(ddeInstance, ddeCookie);
}
if (ddeItem != NULL) {
DdeFreeStringHandle(ddeInstance, ddeItem);
}
if (ddeItemData != NULL) {
DdeFreeDataHandle(ddeItemData);
}
if (ddeData != NULL) {
DdeFreeDataHandle(ddeData);
}
if (hConv != NULL) {
DdeDisconnect(hConv);
}
return TCL_ERROR;
}