os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/win/tclWinDde.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/win/tclWinDde.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1512 @@
1.4 +/*
1.5 + * tclWinDde.c --
1.6 + *
1.7 + * This file provides procedures that implement the "send"
1.8 + * command, allowing commands to be passed from interpreter
1.9 + * to interpreter.
1.10 + *
1.11 + * Copyright (c) 1997 by Sun Microsystems, Inc.
1.12 + *
1.13 + * See the file "license.terms" for information on usage and redistribution
1.14 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.15 + *
1.16 + * RCS: @(#) $Id: tclWinDde.c,v 1.13.2.7 2006/04/05 20:50:46 dgp Exp $
1.17 + */
1.18 +
1.19 +#include "tclPort.h"
1.20 +#include <dde.h>
1.21 +#include <ddeml.h>
1.22 +#include <tchar.h>
1.23 +
1.24 +/*
1.25 + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
1.26 + * Registry_Init declaration is in the source file itself, which is only
1.27 + * accessed when we are building a library.
1.28 + */
1.29 +
1.30 +#undef TCL_STORAGE_CLASS
1.31 +#define TCL_STORAGE_CLASS DLLEXPORT
1.32 +
1.33 +/*
1.34 + * The following structure is used to keep track of the interpreters
1.35 + * registered by this process.
1.36 + */
1.37 +
1.38 +typedef struct RegisteredInterp {
1.39 + struct RegisteredInterp *nextPtr;
1.40 + /* The next interp this application knows
1.41 + * about. */
1.42 + char *name; /* Interpreter's name (malloc-ed). */
1.43 + Tcl_Interp *interp; /* The interpreter attached to this name. */
1.44 +} RegisteredInterp;
1.45 +
1.46 +/*
1.47 + * Used to keep track of conversations.
1.48 + */
1.49 +
1.50 +typedef struct Conversation {
1.51 + struct Conversation *nextPtr;
1.52 + /* The next conversation in the list. */
1.53 + RegisteredInterp *riPtr; /* The info we know about the conversation. */
1.54 + HCONV hConv; /* The DDE handle for this conversation. */
1.55 + Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
1.56 +} Conversation;
1.57 +
1.58 +typedef struct ThreadSpecificData {
1.59 + Conversation *currentConversations;
1.60 + /* A list of conversations currently
1.61 + * being processed. */
1.62 + RegisteredInterp *interpListPtr;
1.63 + /* List of all interpreters registered
1.64 + * in the current process. */
1.65 +} ThreadSpecificData;
1.66 +static Tcl_ThreadDataKey dataKey;
1.67 +
1.68 +/*
1.69 + * The following variables cannot be placed in thread-local storage.
1.70 + * The Mutex ddeMutex guards access to the ddeInstance.
1.71 + */
1.72 +static HSZ ddeServiceGlobal = 0;
1.73 +static DWORD ddeInstance; /* The application instance handle given
1.74 + * to us by DdeInitialize. */
1.75 +static int ddeIsServer = 0;
1.76 +
1.77 +#define TCL_DDE_VERSION "1.2.4"
1.78 +#define TCL_DDE_PACKAGE_NAME "dde"
1.79 +#define TCL_DDE_SERVICE_NAME "TclEval"
1.80 +
1.81 +TCL_DECLARE_MUTEX(ddeMutex)
1.82 +
1.83 +/*
1.84 + * Forward declarations for procedures defined later in this file.
1.85 + */
1.86 +
1.87 +static void DdeExitProc _ANSI_ARGS_((ClientData clientData));
1.88 +static void DeleteProc _ANSI_ARGS_((ClientData clientData));
1.89 +static Tcl_Obj * ExecuteRemoteObject _ANSI_ARGS_((
1.90 + RegisteredInterp *riPtr,
1.91 + Tcl_Obj *ddeObjectPtr));
1.92 +static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp,
1.93 + char *name, HCONV *ddeConvPtr));
1.94 +static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType,
1.95 + UINT uFmt, HCONV hConv, HSZ ddeTopic,
1.96 + HSZ ddeItem, HDDEDATA hData, DWORD dwData1,
1.97 + DWORD dwData2));
1.98 +static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp));
1.99 +static int DdeGetServicesList _ANSI_ARGS_((
1.100 + Tcl_Interp *interp,
1.101 + char *serviceName,
1.102 + char *topicName));
1.103 +int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */
1.104 + Tcl_Interp *interp, /* The interp we are sending from */
1.105 + int objc, /* Number of arguments */
1.106 + Tcl_Obj *CONST objv[]); /* The arguments */
1.107 +
1.108 +EXTERN int Dde_Init(Tcl_Interp *interp);
1.109 +
1.110 +/*
1.111 + *----------------------------------------------------------------------
1.112 + *
1.113 + * Dde_Init --
1.114 + *
1.115 + * This procedure initializes the dde command.
1.116 + *
1.117 + * Results:
1.118 + * A standard Tcl result.
1.119 + *
1.120 + * Side effects:
1.121 + * None.
1.122 + *
1.123 + *----------------------------------------------------------------------
1.124 + */
1.125 +
1.126 +int
1.127 +Dde_Init(
1.128 + Tcl_Interp *interp)
1.129 +{
1.130 + ThreadSpecificData *tsdPtr;
1.131 +
1.132 + if (!Tcl_InitStubs(interp, "8.0", 0)) {
1.133 + return TCL_ERROR;
1.134 + }
1.135 +
1.136 + Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL);
1.137 +
1.138 + tsdPtr = TCL_TSD_INIT(&dataKey);
1.139 +
1.140 + Tcl_CreateExitHandler(DdeExitProc, NULL);
1.141 +
1.142 + return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
1.143 +}
1.144 +
1.145 +/*
1.146 + *----------------------------------------------------------------------
1.147 + *
1.148 + * Initialize --
1.149 + *
1.150 + * Initialize the global DDE instance.
1.151 + *
1.152 + * Results:
1.153 + * None.
1.154 + *
1.155 + * Side effects:
1.156 + * Registers the DDE server proc.
1.157 + *
1.158 + *----------------------------------------------------------------------
1.159 + */
1.160 +
1.161 +static void
1.162 +Initialize(void)
1.163 +{
1.164 + int nameFound = 0;
1.165 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.166 +
1.167 + /*
1.168 + * See if the application is already registered; if so, remove its
1.169 + * current name from the registry. The deletion of the command
1.170 + * will take care of disposing of this entry.
1.171 + */
1.172 +
1.173 + if (tsdPtr->interpListPtr != NULL) {
1.174 + nameFound = 1;
1.175 + }
1.176 +
1.177 + /*
1.178 + * Make sure that the DDE server is there. This is done only once,
1.179 + * add an exit handler tear it down.
1.180 + */
1.181 +
1.182 + if (ddeInstance == 0) {
1.183 + Tcl_MutexLock(&ddeMutex);
1.184 + if (ddeInstance == 0) {
1.185 + if (DdeInitialize(&ddeInstance, DdeServerProc,
1.186 + CBF_SKIP_REGISTRATIONS
1.187 + | CBF_SKIP_UNREGISTRATIONS
1.188 + | CBF_FAIL_POKES, 0)
1.189 + != DMLERR_NO_ERROR) {
1.190 + ddeInstance = 0;
1.191 + }
1.192 + }
1.193 + Tcl_MutexUnlock(&ddeMutex);
1.194 + }
1.195 + if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
1.196 + Tcl_MutexLock(&ddeMutex);
1.197 + if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
1.198 + ddeIsServer = 1;
1.199 + Tcl_CreateExitHandler(DdeExitProc, NULL);
1.200 + ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, \
1.201 + TCL_DDE_SERVICE_NAME, 0);
1.202 + DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
1.203 + } else {
1.204 + ddeIsServer = 0;
1.205 + }
1.206 + Tcl_MutexUnlock(&ddeMutex);
1.207 + }
1.208 +}
1.209 +
1.210 +/*
1.211 + *--------------------------------------------------------------
1.212 + *
1.213 + * DdeSetServerName --
1.214 + *
1.215 + * This procedure is called to associate an ASCII name with a Dde
1.216 + * server. If the interpreter has already been named, the
1.217 + * name replaces the old one.
1.218 + *
1.219 + * Results:
1.220 + * The return value is the name actually given to the interp.
1.221 + * This will normally be the same as name, but if name was already
1.222 + * in use for a Dde Server then a name of the form "name #2" will
1.223 + * be chosen, with a high enough number to make the name unique.
1.224 + *
1.225 + * Side effects:
1.226 + * Registration info is saved, thereby allowing the "send" command
1.227 + * to be used later to invoke commands in the application. In
1.228 + * addition, the "send" command is created in the application's
1.229 + * interpreter. The registration will be removed automatically
1.230 + * if the interpreter is deleted or the "send" command is removed.
1.231 + *
1.232 + *--------------------------------------------------------------
1.233 + */
1.234 +
1.235 +static char *
1.236 +DdeSetServerName(
1.237 + Tcl_Interp *interp,
1.238 + char *name /* The name that will be used to
1.239 + * refer to the interpreter in later
1.240 + * "send" commands. Must be globally
1.241 + * unique. */
1.242 + )
1.243 +{
1.244 + int suffix, offset;
1.245 + RegisteredInterp *riPtr, *prevPtr;
1.246 + Tcl_DString dString;
1.247 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.248 +
1.249 + /*
1.250 + * See if the application is already registered; if so, remove its
1.251 + * current name from the registry. The deletion of the command
1.252 + * will take care of disposing of this entry.
1.253 + */
1.254 +
1.255 + for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
1.256 + prevPtr = riPtr, riPtr = riPtr->nextPtr) {
1.257 + if (riPtr->interp == interp) {
1.258 + if (name != NULL) {
1.259 + if (prevPtr == NULL) {
1.260 + tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
1.261 + } else {
1.262 + prevPtr->nextPtr = riPtr->nextPtr;
1.263 + }
1.264 + break;
1.265 + } else {
1.266 + /*
1.267 + * the name was NULL, so the caller is asking for
1.268 + * the name of the current interp.
1.269 + */
1.270 +
1.271 + return riPtr->name;
1.272 + }
1.273 + }
1.274 + }
1.275 +
1.276 + if (name == NULL) {
1.277 + /*
1.278 + * the name was NULL, so the caller is asking for
1.279 + * the name of the current interp, but it doesn't
1.280 + * have a name.
1.281 + */
1.282 +
1.283 + return "";
1.284 + }
1.285 +
1.286 + /*
1.287 + * Pick a name to use for the application. Use "name" if it's not
1.288 + * already in use. Otherwise add a suffix such as " #2", trying
1.289 + * larger and larger numbers until we eventually find one that is
1.290 + * unique.
1.291 + */
1.292 +
1.293 + suffix = 1;
1.294 + offset = 0;
1.295 + Tcl_DStringInit(&dString);
1.296 +
1.297 + /*
1.298 + * We have found a unique name. Now add it to the registry.
1.299 + */
1.300 +
1.301 + riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
1.302 + riPtr->interp = interp;
1.303 + riPtr->name = ckalloc((unsigned int) strlen(name) + 1);
1.304 + riPtr->nextPtr = tsdPtr->interpListPtr;
1.305 + tsdPtr->interpListPtr = riPtr;
1.306 + strcpy(riPtr->name, name);
1.307 +
1.308 + Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
1.309 + (ClientData) riPtr, DeleteProc);
1.310 + if (Tcl_IsSafe(interp)) {
1.311 + Tcl_HideCommand(interp, "dde", "dde");
1.312 + }
1.313 + Tcl_DStringFree(&dString);
1.314 +
1.315 + /*
1.316 + * re-initialize with the new name
1.317 + */
1.318 + Initialize();
1.319 +
1.320 + return riPtr->name;
1.321 +}
1.322 +
1.323 +/*
1.324 + *--------------------------------------------------------------
1.325 + *
1.326 + * DeleteProc
1.327 + *
1.328 + * This procedure is called when the command "dde" is destroyed.
1.329 + *
1.330 + * Results:
1.331 + * none
1.332 + *
1.333 + * Side effects:
1.334 + * The interpreter given by riPtr is unregistered.
1.335 + *
1.336 + *--------------------------------------------------------------
1.337 + */
1.338 +
1.339 +static void
1.340 +DeleteProc(clientData)
1.341 + ClientData clientData; /* The interp we are deleting passed
1.342 + * as ClientData. */
1.343 +{
1.344 + RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
1.345 + RegisteredInterp *searchPtr, *prevPtr;
1.346 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.347 +
1.348 + for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
1.349 + (searchPtr != NULL) && (searchPtr != riPtr);
1.350 + prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
1.351 + /*
1.352 + * Empty loop body.
1.353 + */
1.354 + }
1.355 +
1.356 + if (searchPtr != NULL) {
1.357 + if (prevPtr == NULL) {
1.358 + tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
1.359 + } else {
1.360 + prevPtr->nextPtr = searchPtr->nextPtr;
1.361 + }
1.362 + }
1.363 + ckfree(riPtr->name);
1.364 + Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
1.365 +}
1.366 +
1.367 +/*
1.368 + *--------------------------------------------------------------
1.369 + *
1.370 + * ExecuteRemoteObject --
1.371 + *
1.372 + * Takes the package delivered by DDE and executes it in
1.373 + * the server's interpreter.
1.374 + *
1.375 + * Results:
1.376 + * A list Tcl_Obj * that describes what happened. The first
1.377 + * element is the numerical return code (TCL_ERROR, etc.).
1.378 + * The second element is the result of the script. If the
1.379 + * return result was TCL_ERROR, then the third element
1.380 + * will be the value of the global "errorCode", and the
1.381 + * fourth will be the value of the global "errorInfo".
1.382 + * The return result will have a refCount of 0.
1.383 + *
1.384 + * Side effects:
1.385 + * A Tcl script is run, which can cause all kinds of other
1.386 + * things to happen.
1.387 + *
1.388 + *--------------------------------------------------------------
1.389 + */
1.390 +
1.391 +static Tcl_Obj *
1.392 +ExecuteRemoteObject(
1.393 + RegisteredInterp *riPtr, /* Info about this server. */
1.394 + Tcl_Obj *ddeObjectPtr) /* The object to execute. */
1.395 +{
1.396 + Tcl_Obj *errorObjPtr;
1.397 + Tcl_Obj *returnPackagePtr;
1.398 + int result;
1.399 +
1.400 + result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
1.401 + returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.402 + Tcl_ListObjAppendElement(NULL, returnPackagePtr,
1.403 + Tcl_NewIntObj(result));
1.404 + Tcl_ListObjAppendElement(NULL, returnPackagePtr,
1.405 + Tcl_GetObjResult(riPtr->interp));
1.406 + if (result == TCL_ERROR) {
1.407 + errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
1.408 + TCL_GLOBAL_ONLY);
1.409 + Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
1.410 + errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
1.411 + TCL_GLOBAL_ONLY);
1.412 + Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
1.413 + }
1.414 +
1.415 + return returnPackagePtr;
1.416 +}
1.417 +
1.418 +/*
1.419 + *--------------------------------------------------------------
1.420 + *
1.421 + * DdeServerProc --
1.422 + *
1.423 + * Handles all transactions for this server. Can handle
1.424 + * execute, request, and connect protocols. Dde will
1.425 + * call this routine when a client attempts to run a dde
1.426 + * command using this server.
1.427 + *
1.428 + * Results:
1.429 + * A DDE Handle with the result of the dde command.
1.430 + *
1.431 + * Side effects:
1.432 + * Depending on which command is executed, arbitrary
1.433 + * Tcl scripts can be run.
1.434 + *
1.435 + *--------------------------------------------------------------
1.436 + */
1.437 +
1.438 +static HDDEDATA CALLBACK
1.439 +DdeServerProc (
1.440 + UINT uType, /* The type of DDE transaction we
1.441 + * are performing. */
1.442 + UINT uFmt, /* The format that data is sent or
1.443 + * received. */
1.444 + HCONV hConv, /* The conversation associated with the
1.445 + * current transaction. */
1.446 + HSZ ddeTopic, /* A string handle. Transaction-type
1.447 + * dependent. */
1.448 + HSZ ddeItem, /* A string handle. Transaction-type
1.449 + * dependent. */
1.450 + HDDEDATA hData, /* DDE data. Transaction-type dependent. */
1.451 + DWORD dwData1, /* Transaction-dependent data. */
1.452 + DWORD dwData2) /* Transaction-dependent data. */
1.453 +{
1.454 + Tcl_DString dString;
1.455 + int len;
1.456 + DWORD dlen;
1.457 + char *utilString;
1.458 + Tcl_Obj *ddeObjectPtr;
1.459 + HDDEDATA ddeReturn = NULL;
1.460 + RegisteredInterp *riPtr;
1.461 + Conversation *convPtr, *prevConvPtr;
1.462 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.463 +
1.464 + switch(uType) {
1.465 + case XTYP_CONNECT:
1.466 +
1.467 + /*
1.468 + * Dde is trying to initialize a conversation with us. Check
1.469 + * and make sure we have a valid topic.
1.470 + */
1.471 +
1.472 + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
1.473 + Tcl_DStringInit(&dString);
1.474 + Tcl_DStringSetLength(&dString, len);
1.475 + utilString = Tcl_DStringValue(&dString);
1.476 + DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
1.477 + CP_WINANSI);
1.478 +
1.479 + for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
1.480 + riPtr = riPtr->nextPtr) {
1.481 + if (stricmp(utilString, riPtr->name) == 0) {
1.482 + Tcl_DStringFree(&dString);
1.483 + return (HDDEDATA) TRUE;
1.484 + }
1.485 + }
1.486 +
1.487 + Tcl_DStringFree(&dString);
1.488 + return (HDDEDATA) FALSE;
1.489 +
1.490 + case XTYP_CONNECT_CONFIRM:
1.491 +
1.492 + /*
1.493 + * Dde has decided that we can connect, so it gives us a
1.494 + * conversation handle. We need to keep track of it
1.495 + * so we know which execution result to return in an
1.496 + * XTYP_REQUEST.
1.497 + */
1.498 +
1.499 + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
1.500 + Tcl_DStringInit(&dString);
1.501 + Tcl_DStringSetLength(&dString, len);
1.502 + utilString = Tcl_DStringValue(&dString);
1.503 + DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
1.504 + CP_WINANSI);
1.505 + for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
1.506 + riPtr = riPtr->nextPtr) {
1.507 + if (stricmp(riPtr->name, utilString) == 0) {
1.508 + convPtr = (Conversation *) ckalloc(sizeof(Conversation));
1.509 + convPtr->nextPtr = tsdPtr->currentConversations;
1.510 + convPtr->returnPackagePtr = NULL;
1.511 + convPtr->hConv = hConv;
1.512 + convPtr->riPtr = riPtr;
1.513 + tsdPtr->currentConversations = convPtr;
1.514 + break;
1.515 + }
1.516 + }
1.517 + Tcl_DStringFree(&dString);
1.518 + return (HDDEDATA) TRUE;
1.519 +
1.520 + case XTYP_DISCONNECT:
1.521 +
1.522 + /*
1.523 + * The client has disconnected from our server. Forget this
1.524 + * conversation.
1.525 + */
1.526 +
1.527 + for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
1.528 + convPtr != NULL;
1.529 + prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
1.530 + if (hConv == convPtr->hConv) {
1.531 + if (prevConvPtr == NULL) {
1.532 + tsdPtr->currentConversations = convPtr->nextPtr;
1.533 + } else {
1.534 + prevConvPtr->nextPtr = convPtr->nextPtr;
1.535 + }
1.536 + if (convPtr->returnPackagePtr != NULL) {
1.537 + Tcl_DecrRefCount(convPtr->returnPackagePtr);
1.538 + }
1.539 + ckfree((char *) convPtr);
1.540 + break;
1.541 + }
1.542 + }
1.543 + return (HDDEDATA) TRUE;
1.544 +
1.545 + case XTYP_REQUEST:
1.546 +
1.547 + /*
1.548 + * This could be either a request for a value of a Tcl variable,
1.549 + * or it could be the send command requesting the results of the
1.550 + * last execute.
1.551 + */
1.552 +
1.553 + if (uFmt != CF_TEXT) {
1.554 + return (HDDEDATA) FALSE;
1.555 + }
1.556 +
1.557 + ddeReturn = (HDDEDATA) FALSE;
1.558 + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
1.559 + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
1.560 + /*
1.561 + * Empty loop body.
1.562 + */
1.563 + }
1.564 +
1.565 + if (convPtr != NULL) {
1.566 + char *returnString;
1.567 +
1.568 + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0,
1.569 + CP_WINANSI);
1.570 + Tcl_DStringInit(&dString);
1.571 + Tcl_DStringSetLength(&dString, len);
1.572 + utilString = Tcl_DStringValue(&dString);
1.573 + DdeQueryString(ddeInstance, ddeItem, utilString,
1.574 + (DWORD) len + 1, CP_WINANSI);
1.575 + if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) {
1.576 + returnString =
1.577 + Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
1.578 + ddeReturn = DdeCreateDataHandle(ddeInstance,
1.579 + returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT,
1.580 + 0);
1.581 + } else {
1.582 + Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
1.583 + convPtr->riPtr->interp, utilString, NULL,
1.584 + TCL_GLOBAL_ONLY);
1.585 + if (variableObjPtr != NULL) {
1.586 + returnString = Tcl_GetStringFromObj(variableObjPtr,
1.587 + &len);
1.588 + ddeReturn = DdeCreateDataHandle(ddeInstance,
1.589 + returnString, (DWORD) len+1, 0, ddeItem,
1.590 + CF_TEXT, 0);
1.591 + } else {
1.592 + ddeReturn = NULL;
1.593 + }
1.594 + }
1.595 + Tcl_DStringFree(&dString);
1.596 + }
1.597 + return ddeReturn;
1.598 +
1.599 + case XTYP_EXECUTE: {
1.600 +
1.601 + /*
1.602 + * Execute this script. The results will be saved into
1.603 + * a list object which will be retreived later. See
1.604 + * ExecuteRemoteObject.
1.605 + */
1.606 +
1.607 + Tcl_Obj *returnPackagePtr;
1.608 +
1.609 + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
1.610 + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
1.611 + /*
1.612 + * Empty loop body.
1.613 + */
1.614 +
1.615 + }
1.616 +
1.617 + if (convPtr == NULL) {
1.618 + return (HDDEDATA) DDE_FNOTPROCESSED;
1.619 + }
1.620 +
1.621 + utilString = (char *) DdeAccessData(hData, &dlen);
1.622 + len = dlen;
1.623 + ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
1.624 + Tcl_IncrRefCount(ddeObjectPtr);
1.625 + DdeUnaccessData(hData);
1.626 + if (convPtr->returnPackagePtr != NULL) {
1.627 + Tcl_DecrRefCount(convPtr->returnPackagePtr);
1.628 + }
1.629 + convPtr->returnPackagePtr = NULL;
1.630 + returnPackagePtr =
1.631 + ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
1.632 + Tcl_IncrRefCount(returnPackagePtr);
1.633 + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
1.634 + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
1.635 + /*
1.636 + * Empty loop body.
1.637 + */
1.638 +
1.639 + }
1.640 + if (convPtr != NULL) {
1.641 + convPtr->returnPackagePtr = returnPackagePtr;
1.642 + } else {
1.643 + Tcl_DecrRefCount(returnPackagePtr);
1.644 + }
1.645 + Tcl_DecrRefCount(ddeObjectPtr);
1.646 + if (returnPackagePtr == NULL) {
1.647 + return (HDDEDATA) DDE_FNOTPROCESSED;
1.648 + } else {
1.649 + return (HDDEDATA) DDE_FACK;
1.650 + }
1.651 + }
1.652 +
1.653 + case XTYP_WILDCONNECT: {
1.654 +
1.655 + /*
1.656 + * Dde wants a list of services and topics that we support.
1.657 + */
1.658 +
1.659 + HSZPAIR *returnPtr;
1.660 + int i;
1.661 + int numItems;
1.662 +
1.663 + for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL;
1.664 + i++, riPtr = riPtr->nextPtr) {
1.665 + /*
1.666 + * Empty loop body.
1.667 + */
1.668 +
1.669 + }
1.670 +
1.671 + numItems = i;
1.672 + ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
1.673 + (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
1.674 + returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
1.675 + len = dlen;
1.676 + for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
1.677 + i++, riPtr = riPtr->nextPtr) {
1.678 + returnPtr[i].hszSvc = DdeCreateStringHandle(
1.679 + ddeInstance, "TclEval", CP_WINANSI);
1.680 + returnPtr[i].hszTopic = DdeCreateStringHandle(
1.681 + ddeInstance, riPtr->name, CP_WINANSI);
1.682 + }
1.683 + returnPtr[i].hszSvc = NULL;
1.684 + returnPtr[i].hszTopic = NULL;
1.685 + DdeUnaccessData(ddeReturn);
1.686 + return ddeReturn;
1.687 + }
1.688 +
1.689 + }
1.690 + return NULL;
1.691 +}
1.692 +
1.693 +/*
1.694 + *--------------------------------------------------------------
1.695 + *
1.696 + * DdeExitProc --
1.697 + *
1.698 + * Gets rid of our DDE server when we go away.
1.699 + *
1.700 + * Results:
1.701 + * None.
1.702 + *
1.703 + * Side effects:
1.704 + * The DDE server is deleted.
1.705 + *
1.706 + *--------------------------------------------------------------
1.707 + */
1.708 +
1.709 +static void
1.710 +DdeExitProc(
1.711 + ClientData clientData) /* Not used in this handler. */
1.712 +{
1.713 + DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
1.714 + DdeUninitialize(ddeInstance);
1.715 + ddeInstance = 0;
1.716 +}
1.717 +
1.718 +/*
1.719 + *--------------------------------------------------------------
1.720 + *
1.721 + * MakeDdeConnection --
1.722 + *
1.723 + * This procedure is a utility used to connect to a DDE
1.724 + * server when given a server name and a topic name.
1.725 + *
1.726 + * Results:
1.727 + * A standard Tcl result.
1.728 + *
1.729 + *
1.730 + * Side effects:
1.731 + * Passes back a conversation through ddeConvPtr
1.732 + *
1.733 + *--------------------------------------------------------------
1.734 + */
1.735 +
1.736 +static int
1.737 +MakeDdeConnection(
1.738 + Tcl_Interp *interp, /* Used to report errors. */
1.739 + char *name, /* The connection to use. */
1.740 + HCONV *ddeConvPtr)
1.741 +{
1.742 + HSZ ddeTopic, ddeService;
1.743 + HCONV ddeConv;
1.744 +
1.745 + ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
1.746 + ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
1.747 +
1.748 + ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1.749 + DdeFreeStringHandle(ddeInstance, ddeService);
1.750 + DdeFreeStringHandle(ddeInstance, ddeTopic);
1.751 +
1.752 + if (ddeConv == (HCONV) NULL) {
1.753 + if (interp != NULL) {
1.754 + Tcl_AppendResult(interp, "no registered server named \"",
1.755 + name, "\"", (char *) NULL);
1.756 + }
1.757 + return TCL_ERROR;
1.758 + }
1.759 +
1.760 + *ddeConvPtr = ddeConv;
1.761 + return TCL_OK;
1.762 +}
1.763 +
1.764 +/*
1.765 + *--------------------------------------------------------------
1.766 + *
1.767 + * DdeGetServicesList --
1.768 + *
1.769 + * This procedure obtains the list of DDE services.
1.770 + *
1.771 + * The functions between here and this procedure are all
1.772 + * involved with handling the DDE callbacks for this.
1.773 + *
1.774 + * Results:
1.775 + * A standard Tcl result.
1.776 + *
1.777 + * Side effects:
1.778 + * Sets the services list into the interp result.
1.779 + *
1.780 + *--------------------------------------------------------------
1.781 + */
1.782 +
1.783 +typedef struct ddeEnumServices {
1.784 + Tcl_Interp *interp;
1.785 + int result;
1.786 + ATOM service;
1.787 + ATOM topic;
1.788 + HWND hwnd;
1.789 +} ddeEnumServices;
1.790 +
1.791 +LRESULT CALLBACK
1.792 +DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam);
1.793 +static LRESULT
1.794 +DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam);
1.795 +
1.796 +static int
1.797 +DdeCreateClient(ddeEnumServices *es)
1.798 +{
1.799 + WNDCLASSEX wc;
1.800 + static const char *szDdeClientClassName = "TclEval client class";
1.801 + static const char *szDdeClientWindowName = "TclEval client window";
1.802 +
1.803 + memset(&wc, 0, sizeof(wc));
1.804 + wc.cbSize = sizeof(wc);
1.805 + wc.lpfnWndProc = DdeClientWindowProc;
1.806 + wc.lpszClassName = szDdeClientClassName;
1.807 + wc.cbWndExtra = sizeof(ddeEnumServices*);
1.808 +
1.809 + /* register and create the callback window */
1.810 + RegisterClassEx(&wc);
1.811 + es->hwnd = CreateWindowEx(0, szDdeClientClassName,
1.812 + szDdeClientWindowName,
1.813 + WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL,
1.814 + (LPVOID)es);
1.815 + return TCL_OK;
1.816 +}
1.817 +
1.818 +LRESULT CALLBACK
1.819 +DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)
1.820 +{
1.821 + LRESULT lr = 0L;
1.822 +
1.823 + switch (uMsg) {
1.824 + case WM_CREATE: {
1.825 + LPCREATESTRUCT lpcs = (LPCREATESTRUCT)lParam;
1.826 + ddeEnumServices *es;
1.827 + es = (ddeEnumServices*)lpcs->lpCreateParams;
1.828 +#ifdef _WIN64
1.829 + SetWindowLongPtr(hwnd, GWLP_USERDATA, (long)es);
1.830 +#else
1.831 + SetWindowLong(hwnd, GWL_USERDATA, (long)es);
1.832 +#endif
1.833 + break;
1.834 + }
1.835 + case WM_DDE_ACK:
1.836 + lr = DdeServicesOnAck(hwnd, wParam, lParam);
1.837 + break;
1.838 + default:
1.839 + lr = DefWindowProc(hwnd, uMsg, wParam, lParam);
1.840 + }
1.841 + return lr;
1.842 +}
1.843 +
1.844 +static LRESULT
1.845 +DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam)
1.846 +{
1.847 + HWND hwndRemote = (HWND)wParam;
1.848 + ATOM service = (ATOM)LOWORD(lParam);
1.849 + ATOM topic = (ATOM)HIWORD(lParam);
1.850 + ddeEnumServices *es;
1.851 + TCHAR sz[255];
1.852 +
1.853 +#ifdef _WIN64
1.854 + es = (ddeEnumServices *)GetWindowLongPtr(hwnd, GWLP_USERDATA);
1.855 +#else
1.856 + es = (ddeEnumServices *)GetWindowLong(hwnd, GWL_USERDATA);
1.857 +#endif
1.858 +
1.859 + if ((es->service == (ATOM)NULL || es->service == service)
1.860 + && (es->topic == (ATOM)NULL || es->topic == topic)) {
1.861 + Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
1.862 +
1.863 + GlobalGetAtomName(service, sz, 255);
1.864 + Tcl_ListObjAppendElement(es->interp, matchPtr,
1.865 + Tcl_NewStringObj(sz, -1));
1.866 + GlobalGetAtomName(topic, sz, 255);
1.867 + Tcl_ListObjAppendElement(es->interp, matchPtr,
1.868 + Tcl_NewStringObj(sz, -1));
1.869 + /* Adding the hwnd as a third list element provides a unique
1.870 + * identifier in the case of multiple servers with the name
1.871 + * application and topic names.
1.872 + */
1.873 + /* Needs a TIP though
1.874 + * Tcl_ListObjAppendElement(es->interp, matchPtr,
1.875 + * Tcl_NewLongObj((long)hwndRemote));
1.876 + */
1.877 + Tcl_ListObjAppendElement(es->interp,
1.878 + Tcl_GetObjResult(es->interp), matchPtr);
1.879 + }
1.880 +
1.881 + /* tell the server we are no longer interested */
1.882 + PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
1.883 + return 0L;
1.884 +}
1.885 +
1.886 +static BOOL CALLBACK
1.887 +DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam)
1.888 +{
1.889 + LRESULT dwResult = 0;
1.890 + ddeEnumServices *es = (ddeEnumServices *)lParam;
1.891 + SendMessageTimeout(hwndTarget, WM_DDE_INITIATE,
1.892 + (WPARAM)es->hwnd,
1.893 + MAKELONG(es->service, es->topic),
1.894 + SMTO_ABORTIFHUNG, 1000, &dwResult);
1.895 + return TRUE;
1.896 +}
1.897 +
1.898 +static int
1.899 +DdeGetServicesList(Tcl_Interp *interp, char *serviceName, char *topicName)
1.900 +{
1.901 + ddeEnumServices es;
1.902 + int r = TCL_OK;
1.903 + es.interp = interp;
1.904 + es.result = TCL_OK;
1.905 + es.service = (serviceName == NULL)
1.906 + ? (ATOM)NULL : GlobalAddAtom(serviceName);
1.907 + es.topic = (topicName == NULL)
1.908 + ? (ATOM)NULL : GlobalAddAtom(topicName);
1.909 +
1.910 + Tcl_ResetResult(interp); /* our list is to be appended to result. */
1.911 + DdeCreateClient(&es);
1.912 + EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es);
1.913 +
1.914 + if (IsWindow(es.hwnd))
1.915 + DestroyWindow(es.hwnd);
1.916 + if (es.service != (ATOM)NULL)
1.917 + GlobalDeleteAtom(es.service);
1.918 + if (es.topic != (ATOM)NULL)
1.919 + GlobalDeleteAtom(es.topic);
1.920 + return es.result;
1.921 +}
1.922 +
1.923 +/*
1.924 + *--------------------------------------------------------------
1.925 + *
1.926 + * SetDdeError --
1.927 + *
1.928 + * Sets the interp result to a cogent error message
1.929 + * describing the last DDE error.
1.930 + *
1.931 + * Results:
1.932 + * None.
1.933 + *
1.934 + *
1.935 + * Side effects:
1.936 + * The interp's result object is changed.
1.937 + *
1.938 + *--------------------------------------------------------------
1.939 + */
1.940 +
1.941 +static void
1.942 +SetDdeError(
1.943 + Tcl_Interp *interp) /* The interp to put the message in.*/
1.944 +{
1.945 + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
1.946 + int err;
1.947 +
1.948 + err = DdeGetLastError(ddeInstance);
1.949 + switch (err) {
1.950 + case DMLERR_DATAACKTIMEOUT:
1.951 + case DMLERR_EXECACKTIMEOUT:
1.952 + case DMLERR_POKEACKTIMEOUT:
1.953 + Tcl_SetStringObj(resultPtr,
1.954 + "remote interpreter did not respond", -1);
1.955 + break;
1.956 +
1.957 + case DMLERR_BUSY:
1.958 + Tcl_SetStringObj(resultPtr, "remote server is busy", -1);
1.959 + break;
1.960 +
1.961 + case DMLERR_NOTPROCESSED:
1.962 + Tcl_SetStringObj(resultPtr,
1.963 + "remote server cannot handle this command", -1);
1.964 + break;
1.965 +
1.966 + default:
1.967 + Tcl_SetStringObj(resultPtr, "dde command failed", -1);
1.968 + }
1.969 +}
1.970 +
1.971 +/*
1.972 + *--------------------------------------------------------------
1.973 + *
1.974 + * Tcl_DdeObjCmd --
1.975 + *
1.976 + * This procedure is invoked to process the "dde" Tcl command.
1.977 + * See the user documentation for details on what it does.
1.978 + *
1.979 + * Results:
1.980 + * A standard Tcl result.
1.981 + *
1.982 + * Side effects:
1.983 + * See the user documentation.
1.984 + *
1.985 + *--------------------------------------------------------------
1.986 + */
1.987 +
1.988 +int
1.989 +Tcl_DdeObjCmd(
1.990 + ClientData clientData, /* Used only for deletion */
1.991 + Tcl_Interp *interp, /* The interp we are sending from */
1.992 + int objc, /* Number of arguments */
1.993 + Tcl_Obj *CONST objv[]) /* The arguments */
1.994 +{
1.995 + enum {
1.996 + DDE_SERVERNAME,
1.997 + DDE_EXECUTE,
1.998 + DDE_POKE,
1.999 + DDE_REQUEST,
1.1000 + DDE_SERVICES,
1.1001 + DDE_EVAL
1.1002 + };
1.1003 +
1.1004 + static CONST char *ddeCommands[] = {"servername", "execute", "poke",
1.1005 + "request", "services", "eval",
1.1006 + (char *) NULL};
1.1007 + static CONST char *ddeOptions[] = {"-async", (char *) NULL};
1.1008 + static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL};
1.1009 + int index, argIndex;
1.1010 + int async = 0, binary = 0;
1.1011 + int result = TCL_OK;
1.1012 + HSZ ddeService = NULL;
1.1013 + HSZ ddeTopic = NULL;
1.1014 + HSZ ddeItem = NULL;
1.1015 + HDDEDATA ddeData = NULL;
1.1016 + HDDEDATA ddeItemData = NULL;
1.1017 + HCONV hConv = NULL;
1.1018 + HSZ ddeCookie = 0;
1.1019 + char *serviceName, *topicName, *itemString, *dataString;
1.1020 + char *string;
1.1021 + int firstArg, length, dataLength;
1.1022 + DWORD ddeResult;
1.1023 + HDDEDATA ddeReturn;
1.1024 + RegisteredInterp *riPtr;
1.1025 + Tcl_Interp *sendInterp;
1.1026 + Tcl_Obj *objPtr;
1.1027 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.1028 +
1.1029 + /*
1.1030 + * Initialize DDE server/client
1.1031 + */
1.1032 +
1.1033 + if (objc < 2) {
1.1034 + Tcl_WrongNumArgs(interp, 1, objv,
1.1035 + "?-async? serviceName topicName value");
1.1036 + return TCL_ERROR;
1.1037 + }
1.1038 +
1.1039 + if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0,
1.1040 + &index) != TCL_OK) {
1.1041 + return TCL_ERROR;
1.1042 + }
1.1043 +
1.1044 + switch (index) {
1.1045 + case DDE_SERVERNAME:
1.1046 + if ((objc != 3) && (objc != 2)) {
1.1047 + Tcl_WrongNumArgs(interp, 1, objv, "servername ?serverName?");
1.1048 + return TCL_ERROR;
1.1049 + }
1.1050 + firstArg = (objc - 1);
1.1051 + break;
1.1052 + case DDE_EXECUTE:
1.1053 + if ((objc < 5) || (objc > 6)) {
1.1054 + Tcl_WrongNumArgs(interp, 1, objv,
1.1055 + "execute ?-async? serviceName topicName value");
1.1056 + return TCL_ERROR;
1.1057 + }
1.1058 + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
1.1059 + &argIndex) != TCL_OK) {
1.1060 + if (objc != 5) {
1.1061 + Tcl_WrongNumArgs(interp, 1, objv,
1.1062 + "execute ?-async? serviceName topicName value");
1.1063 + return TCL_ERROR;
1.1064 + }
1.1065 + async = 0;
1.1066 + firstArg = 2;
1.1067 + } else {
1.1068 + if (objc != 6) {
1.1069 + Tcl_WrongNumArgs(interp, 1, objv,
1.1070 + "execute ?-async? serviceName topicName value");
1.1071 + return TCL_ERROR;
1.1072 + }
1.1073 + async = 1;
1.1074 + firstArg = 3;
1.1075 + }
1.1076 + break;
1.1077 + case DDE_POKE:
1.1078 + if (objc != 6) {
1.1079 + Tcl_WrongNumArgs(interp, 1, objv,
1.1080 + "poke serviceName topicName item value");
1.1081 + return TCL_ERROR;
1.1082 + }
1.1083 + firstArg = 2;
1.1084 + break;
1.1085 + case DDE_REQUEST:
1.1086 + if ((objc < 5) || (objc > 6)) {
1.1087 + Tcl_WrongNumArgs(interp, 1, objv,
1.1088 + "request ?-binary? serviceName topicName value");
1.1089 + return TCL_ERROR;
1.1090 + }
1.1091 + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
1.1092 + &argIndex) != TCL_OK) {
1.1093 + if (objc != 5) {
1.1094 + Tcl_WrongNumArgs(interp, 1, objv,
1.1095 + "request ?-binary? serviceName topicName value");
1.1096 + return TCL_ERROR;
1.1097 + }
1.1098 + binary = 0;
1.1099 + firstArg = 2;
1.1100 + } else {
1.1101 + if (objc != 6) {
1.1102 + Tcl_WrongNumArgs(interp, 1, objv,
1.1103 + "request ?-binary? serviceName topicName value");
1.1104 + return TCL_ERROR;
1.1105 + }
1.1106 + binary = 1;
1.1107 + firstArg = 3;
1.1108 + }
1.1109 + break;
1.1110 + case DDE_SERVICES:
1.1111 + if (objc != 4) {
1.1112 + Tcl_WrongNumArgs(interp, 1, objv,
1.1113 + "services serviceName topicName");
1.1114 + return TCL_ERROR;
1.1115 + }
1.1116 + firstArg = 2;
1.1117 + break;
1.1118 + case DDE_EVAL:
1.1119 + if (objc < 4) {
1.1120 + Tcl_WrongNumArgs(interp, 1, objv,
1.1121 + "eval ?-async? serviceName args");
1.1122 + return TCL_ERROR;
1.1123 + }
1.1124 + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
1.1125 + &argIndex) != TCL_OK) {
1.1126 + if (objc < 4) {
1.1127 + Tcl_WrongNumArgs(interp, 1, objv,
1.1128 + "eval ?-async? serviceName args");
1.1129 + return TCL_ERROR;
1.1130 + }
1.1131 + async = 0;
1.1132 + firstArg = 2;
1.1133 + } else {
1.1134 + if (objc < 5) {
1.1135 + Tcl_WrongNumArgs(interp, 1, objv,
1.1136 + "eval ?-async? serviceName args");
1.1137 + return TCL_ERROR;
1.1138 + }
1.1139 + async = 1;
1.1140 + firstArg = 3;
1.1141 + }
1.1142 + break;
1.1143 + }
1.1144 +
1.1145 + Initialize();
1.1146 +
1.1147 + if (firstArg != 1) {
1.1148 + serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
1.1149 + } else {
1.1150 + length = 0;
1.1151 + }
1.1152 +
1.1153 + if (length == 0) {
1.1154 + serviceName = NULL;
1.1155 + } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
1.1156 + ddeService = DdeCreateStringHandle(ddeInstance, serviceName,
1.1157 + CP_WINANSI);
1.1158 + }
1.1159 +
1.1160 + if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) {
1.1161 + topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
1.1162 + if (length == 0) {
1.1163 + topicName = NULL;
1.1164 + } else {
1.1165 + ddeTopic = DdeCreateStringHandle(ddeInstance,
1.1166 + topicName, CP_WINANSI);
1.1167 + }
1.1168 + }
1.1169 +
1.1170 + switch (index) {
1.1171 + case DDE_SERVERNAME: {
1.1172 + serviceName = DdeSetServerName(interp, serviceName);
1.1173 + if (serviceName != NULL) {
1.1174 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1175 + serviceName, -1);
1.1176 + } else {
1.1177 + Tcl_ResetResult(interp);
1.1178 + }
1.1179 + break;
1.1180 + }
1.1181 + case DDE_EXECUTE: {
1.1182 + dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
1.1183 + if (dataLength == 0) {
1.1184 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1185 + "cannot execute null data", -1);
1.1186 + result = TCL_ERROR;
1.1187 + break;
1.1188 + }
1.1189 + hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1.1190 + DdeFreeStringHandle(ddeInstance, ddeService);
1.1191 + DdeFreeStringHandle(ddeInstance, ddeTopic);
1.1192 +
1.1193 + if (hConv == NULL) {
1.1194 + SetDdeError(interp);
1.1195 + result = TCL_ERROR;
1.1196 + break;
1.1197 + }
1.1198 +
1.1199 + ddeData = DdeCreateDataHandle(ddeInstance, dataString,
1.1200 + (DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
1.1201 + if (ddeData != NULL) {
1.1202 + if (async) {
1.1203 + DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
1.1204 + CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
1.1205 + DdeAbandonTransaction(ddeInstance, hConv,
1.1206 + ddeResult);
1.1207 + } else {
1.1208 + ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
1.1209 + hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
1.1210 + if (ddeReturn == 0) {
1.1211 + SetDdeError(interp);
1.1212 + result = TCL_ERROR;
1.1213 + }
1.1214 + }
1.1215 + DdeFreeDataHandle(ddeData);
1.1216 + } else {
1.1217 + SetDdeError(interp);
1.1218 + result = TCL_ERROR;
1.1219 + }
1.1220 + break;
1.1221 + }
1.1222 + case DDE_REQUEST: {
1.1223 + itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
1.1224 + if (length == 0) {
1.1225 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1226 + "cannot request value of null data", -1);
1.1227 + goto errorNoResult;
1.1228 + }
1.1229 + hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1.1230 + DdeFreeStringHandle(ddeInstance, ddeService);
1.1231 + DdeFreeStringHandle(ddeInstance, ddeTopic);
1.1232 +
1.1233 + if (hConv == NULL) {
1.1234 + SetDdeError(interp);
1.1235 + result = TCL_ERROR;
1.1236 + } else {
1.1237 + Tcl_Obj *returnObjPtr;
1.1238 + ddeItem = DdeCreateStringHandle(ddeInstance,
1.1239 + itemString, CP_WINANSI);
1.1240 + if (ddeItem != NULL) {
1.1241 + ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
1.1242 + CF_TEXT, XTYP_REQUEST, 5000, NULL);
1.1243 + if (ddeData == NULL) {
1.1244 + SetDdeError(interp);
1.1245 + result = TCL_ERROR;
1.1246 + } else {
1.1247 + DWORD tmp;
1.1248 + dataString = DdeAccessData(ddeData, &tmp);
1.1249 + dataLength = tmp;
1.1250 + if (binary) {
1.1251 + returnObjPtr = Tcl_NewByteArrayObj(dataString,
1.1252 + dataLength);
1.1253 + } else {
1.1254 + returnObjPtr = Tcl_NewStringObj(dataString, -1);
1.1255 + }
1.1256 + DdeUnaccessData(ddeData);
1.1257 + DdeFreeDataHandle(ddeData);
1.1258 + Tcl_SetObjResult(interp, returnObjPtr);
1.1259 + }
1.1260 + } else {
1.1261 + SetDdeError(interp);
1.1262 + result = TCL_ERROR;
1.1263 + }
1.1264 + }
1.1265 +
1.1266 + break;
1.1267 + }
1.1268 + case DDE_POKE: {
1.1269 + itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
1.1270 + if (length == 0) {
1.1271 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1272 + "cannot have a null item", -1);
1.1273 + goto errorNoResult;
1.1274 + }
1.1275 + dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
1.1276 +
1.1277 + hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1.1278 + DdeFreeStringHandle(ddeInstance, ddeService);
1.1279 + DdeFreeStringHandle(ddeInstance, ddeTopic);
1.1280 +
1.1281 + if (hConv == NULL) {
1.1282 + SetDdeError(interp);
1.1283 + result = TCL_ERROR;
1.1284 + } else {
1.1285 + ddeItem = DdeCreateStringHandle(ddeInstance, itemString,
1.1286 + CP_WINANSI);
1.1287 + if (ddeItem != NULL) {
1.1288 + ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
1.1289 + hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
1.1290 + if (ddeData == NULL) {
1.1291 + SetDdeError(interp);
1.1292 + result = TCL_ERROR;
1.1293 + }
1.1294 + } else {
1.1295 + SetDdeError(interp);
1.1296 + result = TCL_ERROR;
1.1297 + }
1.1298 + }
1.1299 + break;
1.1300 + }
1.1301 +
1.1302 + case DDE_SERVICES: {
1.1303 + result = DdeGetServicesList(interp, serviceName, topicName);
1.1304 + break;
1.1305 + }
1.1306 + case DDE_EVAL: {
1.1307 + if (serviceName == NULL) {
1.1308 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1309 + "invalid service name \"\"", -1);
1.1310 + goto errorNoResult;
1.1311 + }
1.1312 +
1.1313 + objc -= (async + 3);
1.1314 + ((Tcl_Obj **) objv) += (async + 3);
1.1315 +
1.1316 + /*
1.1317 + * See if the target interpreter is local. If so, execute
1.1318 + * the command directly without going through the DDE server.
1.1319 + * Don't exchange objects between interps. The target interp could
1.1320 + * compile an object, producing a bytecode structure that refers to
1.1321 + * other objects owned by the target interp. If the target interp
1.1322 + * is then deleted, the bytecode structure would be referring to
1.1323 + * deallocated objects.
1.1324 + */
1.1325 +
1.1326 + for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
1.1327 + riPtr = riPtr->nextPtr) {
1.1328 + if (stricmp(serviceName, riPtr->name) == 0) {
1.1329 + break;
1.1330 + }
1.1331 + }
1.1332 +
1.1333 + if (riPtr != NULL) {
1.1334 + /*
1.1335 + * This command is to a local interp. No need to go through
1.1336 + * the server.
1.1337 + */
1.1338 +
1.1339 + Tcl_Preserve((ClientData) riPtr);
1.1340 + sendInterp = riPtr->interp;
1.1341 + Tcl_Preserve((ClientData) sendInterp);
1.1342 +
1.1343 + /*
1.1344 + * Don't exchange objects between interps. The target interp
1.1345 + * would compile an object, producing a bytecode structure that
1.1346 + * refers to other objects owned by the target interp. If the
1.1347 + * target interp is then deleted, the bytecode structure would
1.1348 + * be referring to deallocated objects.
1.1349 + */
1.1350 +
1.1351 + if (objc == 1) {
1.1352 + result = Tcl_EvalObjEx(sendInterp, objv[0],
1.1353 + TCL_EVAL_GLOBAL);
1.1354 + } else {
1.1355 + objPtr = Tcl_ConcatObj(objc, objv);
1.1356 + Tcl_IncrRefCount(objPtr);
1.1357 + result = Tcl_EvalObjEx(sendInterp, objPtr,
1.1358 + TCL_EVAL_GLOBAL);
1.1359 + Tcl_DecrRefCount(objPtr);
1.1360 + }
1.1361 + if (interp != sendInterp) {
1.1362 + if (result == TCL_ERROR) {
1.1363 + /*
1.1364 + * An error occurred, so transfer error information
1.1365 + * from the destination interpreter back to our
1.1366 + * interpreter.
1.1367 + */
1.1368 +
1.1369 + Tcl_ResetResult(interp);
1.1370 + objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
1.1371 + TCL_GLOBAL_ONLY);
1.1372 + string = Tcl_GetStringFromObj(objPtr, &length);
1.1373 + Tcl_AddObjErrorInfo(interp, string, length);
1.1374 +
1.1375 + objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
1.1376 + TCL_GLOBAL_ONLY);
1.1377 + Tcl_SetObjErrorCode(interp, objPtr);
1.1378 + }
1.1379 + Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
1.1380 + }
1.1381 + Tcl_Release((ClientData) riPtr);
1.1382 + Tcl_Release((ClientData) sendInterp);
1.1383 + } else {
1.1384 + /*
1.1385 + * This is a non-local request. Send the script to the server
1.1386 + * and poll it for a result.
1.1387 + */
1.1388 +
1.1389 + if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
1.1390 + goto error;
1.1391 + }
1.1392 +
1.1393 + objPtr = Tcl_ConcatObj(objc, objv);
1.1394 + string = Tcl_GetStringFromObj(objPtr, &length);
1.1395 + ddeItemData = DdeCreateDataHandle(ddeInstance, string,
1.1396 + (DWORD) length+1, 0, 0, CF_TEXT, 0);
1.1397 +
1.1398 + if (async) {
1.1399 + ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
1.1400 + 0xFFFFFFFF, hConv, 0,
1.1401 + CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
1.1402 + DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
1.1403 + } else {
1.1404 + ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
1.1405 + 0xFFFFFFFF, hConv, 0,
1.1406 + CF_TEXT, XTYP_EXECUTE, 30000, NULL);
1.1407 + if (ddeData != 0) {
1.1408 +
1.1409 + ddeCookie = DdeCreateStringHandle(ddeInstance,
1.1410 + "$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
1.1411 + ddeData = DdeClientTransaction(NULL, 0, hConv,
1.1412 + ddeCookie, CF_TEXT, XTYP_REQUEST, 30000, NULL);
1.1413 + }
1.1414 + }
1.1415 +
1.1416 + Tcl_DecrRefCount(objPtr);
1.1417 +
1.1418 + if (ddeData == 0) {
1.1419 + SetDdeError(interp);
1.1420 + goto errorNoResult;
1.1421 + }
1.1422 +
1.1423 + if (async == 0) {
1.1424 + Tcl_Obj *resultPtr;
1.1425 +
1.1426 + /*
1.1427 + * The return handle has a two or four element list in
1.1428 + * it. The first element is the return code (TCL_OK,
1.1429 + * TCL_ERROR, etc.). The second is the result of the
1.1430 + * script. If the return code is TCL_ERROR, then the third
1.1431 + * element is the value of the variable "errorCode", and
1.1432 + * the fourth is the value of the variable "errorInfo".
1.1433 + */
1.1434 +
1.1435 + resultPtr = Tcl_NewObj();
1.1436 + length = DdeGetData(ddeData, NULL, 0, 0);
1.1437 + Tcl_SetObjLength(resultPtr, length);
1.1438 + string = Tcl_GetString(resultPtr);
1.1439 + DdeGetData(ddeData, string, (DWORD) length, 0);
1.1440 + Tcl_SetObjLength(resultPtr, (int) strlen(string));
1.1441 +
1.1442 + if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr)
1.1443 + != TCL_OK) {
1.1444 + Tcl_DecrRefCount(resultPtr);
1.1445 + goto error;
1.1446 + }
1.1447 + if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
1.1448 + Tcl_DecrRefCount(resultPtr);
1.1449 + goto error;
1.1450 + }
1.1451 + if (result == TCL_ERROR) {
1.1452 + Tcl_ResetResult(interp);
1.1453 +
1.1454 + if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr)
1.1455 + != TCL_OK) {
1.1456 + Tcl_DecrRefCount(resultPtr);
1.1457 + goto error;
1.1458 + }
1.1459 + length = -1;
1.1460 + string = Tcl_GetStringFromObj(objPtr, &length);
1.1461 + Tcl_AddObjErrorInfo(interp, string, length);
1.1462 +
1.1463 + Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
1.1464 + Tcl_SetObjErrorCode(interp, objPtr);
1.1465 + }
1.1466 + if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr)
1.1467 + != TCL_OK) {
1.1468 + Tcl_DecrRefCount(resultPtr);
1.1469 + goto error;
1.1470 + }
1.1471 + Tcl_SetObjResult(interp, objPtr);
1.1472 + Tcl_DecrRefCount(resultPtr);
1.1473 + }
1.1474 + }
1.1475 + }
1.1476 + }
1.1477 + if (ddeCookie != NULL) {
1.1478 + DdeFreeStringHandle(ddeInstance, ddeCookie);
1.1479 + }
1.1480 + if (ddeItem != NULL) {
1.1481 + DdeFreeStringHandle(ddeInstance, ddeItem);
1.1482 + }
1.1483 + if (ddeItemData != NULL) {
1.1484 + DdeFreeDataHandle(ddeItemData);
1.1485 + }
1.1486 + if (ddeData != NULL) {
1.1487 + DdeFreeDataHandle(ddeData);
1.1488 + }
1.1489 + if (hConv != NULL) {
1.1490 + DdeDisconnect(hConv);
1.1491 + }
1.1492 + return result;
1.1493 +
1.1494 + error:
1.1495 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1496 + "invalid data returned from server", -1);
1.1497 +
1.1498 + errorNoResult:
1.1499 + if (ddeCookie != NULL) {
1.1500 + DdeFreeStringHandle(ddeInstance, ddeCookie);
1.1501 + }
1.1502 + if (ddeItem != NULL) {
1.1503 + DdeFreeStringHandle(ddeInstance, ddeItem);
1.1504 + }
1.1505 + if (ddeItemData != NULL) {
1.1506 + DdeFreeDataHandle(ddeItemData);
1.1507 + }
1.1508 + if (ddeData != NULL) {
1.1509 + DdeFreeDataHandle(ddeData);
1.1510 + }
1.1511 + if (hConv != NULL) {
1.1512 + DdeDisconnect(hConv);
1.1513 + }
1.1514 + return TCL_ERROR;
1.1515 +}